﻿(* *****************************************************************************
* UVonSystemFuns v1.0 written by James Von (jamesvon@163.com) ******************
********************************************************************************
* 应用系统常用函数集
*------------------------------------------------------------------------------*
*     应用系统在研发的过程中，经常会遇到一些常用函数，而这些函数往往具有一些普遍
* 性和通用性，因此在长期研发的基础上对这些函数进行了整理和加工，以便满足多数应用
* 系统的调用。
*     这个函数集基本上包含了一下几个部分
*     { LOG 日志管理部分 }
*     { Info 信息处理部分 }
*     { Dialog 对话框部分 }
*     { Version 版本管理 }
*     { 缓存各种信息 }
*     { Math.String }
*     { 应用及系统 }
*     { 硬盘区 }
*     { 内存区 }
*     { CPU区 }
*     { Net }
*     { Display }
*     { Other }
*     { 图像处理部分 }
*------------------------------------------------------------------------------*
  IVonFormHelper = interface ['{A89999E2-B199-498C-826F-D78CC90A1B0D}']
  窗口显示后需要加载的内容可以放在这里被执行，只需实现 Init 就可以了。
  例子见 UErpMetal
*=============================================================================*)
(*<summary>A summary of the target function or class</summary>
<para>A paragraph</para>
<c>Text in fixed-width font</c>
<code>Preformatted text, such as source code</code>
<remarks>Remarks regarding the target function or class</remarks>
<param name="ParameterName"></param>
<see>Reference to a specific type, symbol, or identifier</see>
<returns>Description of the return value of the target function. For example, the function might return an error code</returns>
<exception cref="EExceptionTypeName">Exception that can be thrown by a method</exception>
<permission cref="PermissionType">Permissions for a method</permission>   *)
unit UVonSystemFuns;

interface

uses
  SysUtils, Classes, Winapi.Windows, Winapi.Shlobj, Winapi.nb30, Winapi.ShellAPI,
  Variants, Oleauto, Math, Winapi.WinInet, Dialogs, Controls, CheckLst, IniFiles,
  Graphics, Buttons, StdCtrls, Contnrs, Forms, ExtCtrls, Winapi.Messages,
  UVonClass, StrUtils, ComCtrls, GIFImg,ZLib, Winapi.CommCtrl, Winapi.MMSystem,
  MPlayer, ValEdit, Spin, EncdDecd, DB, Data.win.ADODB, WinSVC, WinAPI.WinSock,
  Data.win.AdoConEd, DBGrids, Winapi.WinSpool, Printers, Types;

resourcestring
  RES_CPU_NO_PROCESSOR = 'Unable to locate the "Processor" performance object';
  RES_CPU_UNABLE_USAGE =
    'Unable to locate the "% of CPU usage" performance counter';
  RES_CPU_UNABLE_PERFORMANCE = 'Unable to start performance monitoring';
  RES_CPU_NOREAD_PERFORMANCE = 'Unable to read performance data';
  RES_CPU_INDEX_OUT = 'CPU index out of bounds';
  RES_DLG_DEL_PROMPT = '真的要删除这条记录吗?';
  RES_DLG_DEL_WARNING = '一旦删除系统将无法恢复，是否继续删除?';
  RES_INFO_CRCERR = '数据库信息被非法篡改，数据无效。';
  RES_INFO_NOLOAFED = '信息尚未提取。';
  RES_INFO_NOTSELECTED = '当前信息与提取的信息不一致';
  RES_INFO_DOUBLICATION = '该信息已存在，不支持重复内容出现。';
  RES_NODE_NONESELECTED = '请先选择后再进行操作。';
  RES_NODE_HASCHILDREN = '含有子节点不允许删除。';
  RES_NO_LOCATE = '该内容信息无法对数据库进行定位。';
  RES_NO_FOUND_STR = '未在数据库中发现%s记录。';
  RES_NO_FOUND_NUM = '未在数据库中发现%d记录。';
  RES_NO_DATA = '未发现记录。';
  RES_MATH_ISNOTFLOAT = '%s数据不是一个浮点类型数据。';
  RES_SYS_OUT_OF_RANG = '超出记录范围。';
  RES_DLG_PROMPT = '提示';
  RES_DLG_WARNING = '警告';
  RES_DLG_ERROR = '错误';
  RES_COMM_NotOpen = '通讯端口尚未打开。';
  RES_DESIGN_NOSTYLE = '样式目录尚未发现.';

const
  CRLF: string = #13 + #10;
  LOG_RTN_SUCCESS = 100;
  LOG_RTN_FAILED = 1;
  LOG_RTN_NOOPEN = 2;
  CHINESE = (SUBLANG_CHINESE_SIMPLIFIED shl 10) or LANG_CHINESE;
  DB_Min_Time : TDatetime = 1;

const
  GUID_VonFormHelper: TGUID = '{A89999E2-B199-498C-826F-D78CC90A1B0D}';

type
  TArrayInt = array of integer;
  PArrayInt = ^TArrayInt;
  TArrayExtended = array of Extended;
  TArrayString = array of String;
  TArrayDate = array of TDateTime;
  TArrayObject = array of TObject;

  TVonVersion = packed record
  private
    function GetHex: string;
    procedure SetHex(const Value: string);
    function GetText: string;
    procedure SetText(const Value: string);
  public
    function Check(V: TVonVersion): Integer;
    property Hex: string read GetHex write SetHex;
    property Text: string read GetText write SetText;
    case integer of
      0: (Int: Int64);
      1: (arr: array[0..3]of word);        //FFFF FFFF FFFF FFFF
      2: (bytes: array[0..7]of byte);      //FF FF FF FF FF FF FF FF
    end;

  PVonVersion = ^TVonVersion;

  RVonInt64 = packed record
    case Integer of
      0:
        (Int: Int64);
      1:
        (Bytes: array [0 .. 7] of Byte);
  end;

  /// <summary>整数，含内存映射4个字节</summary>
  RVonInt = packed record
    case Integer of
      0:
        (Int: Integer);
      1:
        (Bytes: array [0 .. 3] of Byte);
  end;

  RVonDouble = packed record
    case Integer of
      0:
        (Dbl: Double);
      1:
        (Bytes: array [0 .. 7] of Byte);
  end;

  RVonExtended = packed record
    case Integer of
      0:
        (Dbl: Extended);
      1:
        (Bytes: array [0 .. 9] of Byte);
  end;

  RVonBool = packed record
    case Integer of
      0:
        (Bool: Boolean);
      1:
        (Bytes: Byte);
  end;


  TRunType = (dtCloseAll, dtCloseActive, dtMulti, dtModal, dtSingle);
  TEventOnNewChildWin = function (Caption: string; FormClass: TFormClass;
      RunType: TRunType; ControlID: Integer = 0; TaskParam: string = '';
      ExecuteParam: string = '') : TForm of object;

  //窗口初始化接口
  IVonFormHelper = interface(IUnknown)['{A89999E2-B199-498C-826F-D78CC90A1B0D}']
    procedure Init;    //在这里面实现初始化信息
  end;


{ Info 信息处理部分 }

/// <summary>向信息列表中写入信息</summary>
/// <param name="Info">信息</param>
procedure WriteInfo(Info: string);
/// <summary>清除信息列表中的所有信息</summary>
procedure ClearInfo;
/// <summary>得到最后一个信息</summary>
function LastInfo: string;
/// <summary>得到信息列表</summary>
function GetInfoList: TStrings;

{ Dialog 对话框部分 }

/// <summary>调用数据库链接录入对话框</summary>
/// <param name="SConnectionString">原有数据库链接信息</param>
/// <returns>选择录入的结果</returns>
function DlgConnectionString(SConnectionString: string): string;
/// <summary>待定时结束的对话框</summary>
/// <param name="ACaption">对话框标题</param>
/// <param name="Infomation">对话框内提示信息</param>
/// <param name="TimeCount">延时秒数</param>
procedure DlgInfo(ACaption, Infomation: string;
  TimeCount: Integer = 30); overload;
/// <summary>待定时结束的对话框</summary>
/// <param name="ACaption">对话框标题</param>
/// <param name="Infomation">对话框内提示信息</param>
/// <param name="Buttons">呈现按钮</param>
/// <param name="TimeCount">延时秒数</param>
/// <returns>点击按钮结果</returns>
function DlgInfo(ACaption, Infomation: string; Buttons: TMsgDlgButtons;
  TimeCount: Integer = 30): Integer; overload;
/// <summary>多项录入对话框</summary>
/// <param name="Title">对话框标题</param>
/// <param name="NameTitle">项目名称列标题</param>
/// <param name="ValueTitle">项目值列标题</param>
/// <param name="Settings">项目列表，name-value格式，name表示提示内容，不能重复，value为默认值或下拉列表内容，以逗号间隔</param>
/// <returns>是否录入成功</returns>
function DlgMultiInput(Title, NameTitle, ValueTitle: string; Settings: TStrings): Boolean;
/// <summary>待定时结束的对话框</summary>
/// <param name="ACaption">对话框标题</param>
/// <param name="Values">选择项内容列表</param>
/// <param name="Index">默认勾选值</param>
/// <returns>点击按钮结果</returns>
function DlgInfo(ACaption: string; Values: TStrings; Index: Integer = -1): Integer; overload;

function DlgBusy(ACaption: string; GifFilename: string = ''): TForm;
function RunWait(FileName: string; Visibility: Integer): THandle;
function ExcuteWait(FileName, Params: string): THandle;
{ Version 版本管理 }
(*
///// <summary>分解一个版本字符串到版本结构中</summary>
///// <param name="Ver">版本字符串</param>
///// <param name="arrVer">版本信息结构</param>
//procedure SplitVer(Ver: string; var arrVer: TVonVersion);
///// <summary>增加一个版本号的版本</summary>
///// <param name="Ver">版本号</param>
///// <returns>新的版本号</returns>
//function IncVer(Ver: string): string; overload;
//function IncVer(Ver: TVonVersion): TVonVersion; overload;
///// <summary>将一个版本结构转化为字符串形式</summary>
///// <param name="Version">版本信息结构</param>
///// <returns>版本字符串</returns>
//function VerToStr(Version: TVonVersion): string;
///// <summary>复制一个版本值</summary>
///// <param name="OrgVer">原版本信息结构</param>
///// <param name="DestVer">目标版本信息结构</param>
//procedure CopyVer(OrgVer: TVonVersion; var DestVer: TVonVersion);
///// <summary>将一个版本结构转化为十六进制字符串形式</summary>
///// <param name="Version">版本信息结构</param>
///// <returns>版本字符串</returns>
//function VerToHex(Version: TVonVersion): string;
///// <summary>比较两个不同版本差异</summary>
///// <param name="SrcVer">原版本</param>
///// <param name="DestVer">对比版本</param>
///// <returns>如果两个版本一样则返回0，如果原版本比对比版本高则1，如果对比版本比原版本高则-1</returns>
///// <example>CheckVer('1.0.0.1', '1.0.0.2')= -1</example>
///// <example>CheckVer('1.0.0.3', '1.0.0.2')= 1</example>
//function CheckVer(SrcVer, DestVer: string): Integer; overload;
///// <summary>比较两个不同版本差异</summary>
///// <param name="SrcVer">原版本</param>
///// <param name="DestVer">对比版本</param>
///// <returns>如果两个版本一样则返回0，如果原版本比对比版本高则1，如果对比版本比原版本高则-1</returns>
//function CheckVer(SrcVer, DestVer: TVonVersion): Integer; overload;
*)
/// <summary>比较两个不同版本差异，支持*处理</summary>
/// <param name="SrcVer">原版本</param>
/// <param name="DestVer">对比版本</param>
/// <returns>如果两个版本一样则返回true，否则为false</returns>
/// <example>SameVer('1.*.0.1', '1.4.0.2')= true</example>
/// <example>SameVer('1.0.*.*', '1.0.0.2')= true</example>
function SameVer(SrcVer: string; var DestVer: string): Boolean;

{ 缓存各种信息 }

function SetFont(Font: TFont; const Settings: string): Boolean;
function GetFont(Font: TFont): string;

{ Math.String }

/// <summary>生成重复字母，默认是空格</summary>
function Space(Count: Integer = 1; Ch: Char = ' '): string;
/// <summary>生成随机字母</summary>
function RandomStr(Count: Integer; includeUpper, includeLower, IncludeNum, includeSpeical: Boolean): string;
function BIG5ToGB(Str: string): string; // 繁->简
function GBToBIG5(Str: string): string; // 简->繁
/// <summary>Wide String -> Ansi String</summary>
function WideStringToAnsiString(const strWide: WideString; CodePage: Word): AnsiString;
/// <summary>Ansi String -> Wide String</summary>
function AnsiStringToWideString(const strAnsi: AnsiString; CodePage: Word): WideString;
/// <summary>简化地址，去掉省、市等行政名称，只留下楼宇住址信息</summary>
function SimpleAddress(Str: string): string;
/// <summary>得到全拼字母（含声调）</summary>
function FullSpellString(Str: string): string;
/// <summary>得到全拼字母（数字声调）</summary>
function SimpleSpellString(Str: string): string;
/// <summary>得到字母拼音</summary>
function AlphabetSpellString(Str: string): string;
/// <summary>得到字母字头</summary>
function ShortSpellString(Str: string): string;

/// <summary>十六进制转化成十进制</summary>
function HexToInt(Str: string): Int64;
/// <summary>十进制转化成十六进制</summary>
function IntToHex(Value: Int64): string; overload;
/// <summary>十进制转化成十六进制</summary>
function IntToHex(Value: Integer): string; overload;

/// <summary>字符转化成十六进制</summary>
function StrToHex(AStr: string): string;
/// <summary>十六进制转化成字符</summary>
function HexToStr(AStr: string): string;

/// <summary>十进制转二进制</summary>
function IntToBin(TheVal: Longint; const Count: Integer = 0): string;
/// <summary>二进制转十进制</summary>
function BinToInt(S: string): Integer;
/// <summary>十六进制转二进制</summary>
function HexToBin(AStr: string): string;
/// <summary>将十六进制字符串转换为长整数</summary>
function IntToBCD(value: Int64): TBytes;
/// <summary>将数据库中Variation转换数组</summary>
/// <code>
///   var arr: array[0..10] of byte; dbVal: Variant;
///   dbVal := FieldByName('BinaryField').Value;
///   VarToArray(dbVal, arr, 11);
/// </code>
procedure VarToArray(DBBinary: Variant; value: TBytes; len: Integer);
/// <summary>将BCD码转换为整数</summary>
function BCDToInt(BCD: Byte): Word;
/// <summary>将一组BCD码转换为整数</summary>
function BcdsToInt(BCDs: TBytes): Int64;
/// <summary>将UniCode字符串转换为GB</summary>
function GB2UniCode(GB:string): String;
/// <summary>将GB字符串转换为UniCode</summary>
function Unicode2GB(const AStr: AnsiString): AnsiString;
/// <summary>将bytes以十六进制字符串显示出来</summary>
function BytesToHex(Bs: array of byte; Len: Integer): string;
/// <summary>大写(壹贰叁)数字</summary>
function UpperDigit(Value: Double): string;
/// <summary>大写金额</summary>
function UpperCash(Value: Double): string;
/// <summary>大写(一二三)金额</summary>
function UpperNum(Value: Double): string;

/// <summary>将列数转换为字母表示</summary>
function IntToCol(Idx: Integer): string;
/// <summary>将字母表示的列转换为数字</summary>
function ColToInt(ColName: string): Integer;
/// <summary>根据页号、列号、行号输出文字名称</summary>
function GetCellName(Page, Col, Row: Integer): string;
/// <summary>根据单元文字名称输出页号、列号、行号</summary>
function SplitCellName(CellName: PChar; var Page, Col, Row: Integer): Boolean;
/// <summary>将列数转换为中文序列表示</summary>
function IntToCnSerial(Idx: Integer): string;
/// <summary>将delphi的颜色转换为WEB网页指定的颜色</summary>
function ColorToWebColor(Color: TColor): string;
/// <summary>将delphi的时间转换为CRC计算用的字符</summary>
function DateTimeToCrcString(DT: TDatetime): string;
/// <summary>将CRC计算用的字符转换为delphi的时间</summary>
function CrcStringToDatetime(S: string): TDatetime;
/// <summary>计算当前年龄</summary>
function Age(DT: TDatetime): integer;

/// <summary>将一个字符串写入流</summary>
procedure WriteStringToStream(S: string; st: TStream);
/// <summary>将一个流信息写入流</summary>
procedure WriteStreamToStream(Src, Dest: TStream);
/// <summary>将一个字节写入流</summary>
procedure WriteByteToStream(val: Byte; st: TStream);
/// <summary>将一个整数写入流</summary>
procedure WriteIntToStream(val: Integer; st: TStream);
/// <summary>将一个64bit整数写入流</summary>
procedure WriteInt64ToStream(val: Int64; st: TStream);
/// <summary>将一个浮点写入流</summary>
procedure WriteExtendedToStream(val: Extended; st: TStream);
/// <summary>将一个浮点写入流</summary>
procedure WriteDoubleToStream(val: Double; st: TStream);
/// <summary>将一个Guid写入流</summary>
procedure WriteGuidToStream(val: TGuid; st: TStream);
/// <summary>从流的当前位置读取一个字符串信息</summary>
function ReadStringFromStream(st: TStream): string;
/// <summary>从流的当前位置读取信息并写入另一个流中</summary>
procedure ReadStreamFromStream(Src, Dest: TStream);
/// <summary>从流的当前位置读取一个字节信息</summary>
function ReadByteFromStream(st: TStream): Byte;
/// <summary>从流的当前位置读取一个整数信息</summary>
function ReadIntFromStream(st: TStream): Integer;
/// <summary>从流的当前位置读取一个64bit整数信息</summary>
function ReadInt64FromStream(st: TStream): Int64;
/// <summary>从流的当前位置读取一个浮点信息</summary>
function ReadExtendedFromStream(st: TStream): Extended;
/// <summary>从流的当前位置读取一个浮点信息</summary>
function ReadDoubleFromStream(st: TStream): Double;
/// <summary>从流的当前位置读取一个Guid信息</summary>
function ReadGuidFromStream(st: TStream): TGuid;
/// <summary>将byte转换按长度读取字符串</summary>
function BytesToStr(bytes: array of byte; Start: Integer = 0; len: Integer = 0): string; //overload;
/// <summary>将byte按截至字符转换为字符串</summary>
//function BytesToStr(bytes: array of byte; ch: byte; var Idx: Integer): string; overload;
/// <summary>将字符串转换为bytes</summary>
function StrToBytes(S: string; var bytes: array of byte; Size: Integer): Integer;

procedure ReadZipFile(FileName: string; st: TStream);
procedure ReadStringsFromZipFile(FileName: string; st: TStringList);
procedure WriteZipFile(FileName: string; st: TStream);

/// <summary>以某一字符分解文字</summary><param name="Str">要分解的文字</param><param name="Delimiter">间隔字符</param><returns>返回分解列表</returns>
function SplitStr(Str, Delimiter: string): TStringList; overload;
function SplitStr(Str, Delimiters: string; IncludeNull: boolean): TStringList; overload;
function SplitStr(Str: string; ArrValue: array of string; Delimiter: string = ','): Boolean; overload;
// function Min(A, B: Integer): Integer;
// function Min(A, B: Char): Char;
// function Min(A, B: Double): Double;
// function Min(A, B: Int64): Int64;
// function Min(A, B: Extended): Extended;

{ 应用及系统 }

/// <summary>检测用户是否具有administrator权限</summary><returns>是则 true，否则为 false</returns>
function IsAdmin: Boolean;
/// <summary>获取系统语种信息</summary><returns>系统语种信息</returns>
function Get_WindowsLanguage: string; overload;
/// <summary>获取系统语种信息</summary><returns>系统语种信息</returns>
/// <param name="LCTYPE">LOCALE_ILANGUAGE { language id }LOCALE_SLANGUAGE { localized name of language }LOCALE_SENGLANGUAGE { English name of language }LOCALE_SABBREVLANGNAME { abbreviated language name }LOCALE_SNATIVELANGNAME { native name of language } </param>
function Get_WindowsLanguage(LCTYPE: LCTYPE): string; overload;
/// <summary>获取系统版本信息</summary><returns>系统版本信息</returns>
function Get_OSVersionText: string;
/// <summary>获取应用系统版本信息</summary><returns>应用系统版本信息</returns>/// <param name="AppFilename">应用系统执行文件名称</param>
function Get_ApplicationVersion(AppFilename: string): string;
/// <summary>开启服务</summary>
function StartService(const sServiceName: string): Boolean;
/// <summary>停止服务</summary>
function StopService(const SvrName: string): Boolean;
/// <summary>服务是否在运行</summary>
function ServiceIsRunning(sServiceName: string): boolean;

{ 硬盘区 }

/// <summary>获取硬盘使用情况信息</summary><returns>硬盘使用情况信息</returns>
function Get_DiskInfo: string;
/// <summary>获取硬盘序列号</summary><returns>硬盘序列号</returns>
function Get_HDSerialNo: string;
/// <summary>获取Scsi硬盘序列号</summary><returns>硬盘序列号</returns>
function Get_ScsiHDSerialNo: string;
/// <summary>获取Ide硬盘序列号</summary><returns>硬盘序列号</returns>
function Get_IdeHDSerialNo: string;
/// <summary>获取硬盘分区序列号</summary><returns>硬盘分区序列号</returns><param name="DriveID">驱动器盘符</param>
function Get_DiskSerialNo(DriveID: Char): string;

{ 内存区 }

/// <summary>获取物理内存、虚拟内存、交换区(页面)内存的总容量，做初始化动作。</summary>
/// <param name="iPhysicsMemoryTotalSize">返回物理内存总容量</param>
/// <param name="iVirtualMemoryTotalSize">返回虚拟内存总容量</param>
/// <param name="iPageFileMemoryTotalSize">返回交换内存（页面）总容量</param>
procedure Get_MemoryTotalSize(var iPhysicsMemoryTotalSize,
  iVirtualMemoryTotalSize, iPageFileMemoryTotalSize: DWORD);
/// <summary>获取当前物理内存、虚拟内存、交换区(页面)内存的实时可用容量，做监控显示动作。</summary>
/// <param name="iPhysicsMemoryCurrentSize">返回当前物理内存总容量</param>
/// <param name="iVirtualMemoryCurrentSize">返回当前虚拟内存总容量</param>
/// <param name="iPageFileMemoryCurrentSize">返回当前交换内存（页面）总容量</param>
procedure Get_MemoryCurrentSize(var iPhysicsMemoryCurrentSize,
  iVirtualMemoryCurrentSize, iPageFileMemoryCurrentSize: DWORD);
/// <summary>返回内存当前使用率 总的是100%，传回的是0-100%间的使用率，可以自己做转换。</summary>
function Get_MemoryUsage: Double;

{ CPU区 }

/// <summary>获取CPU在系统中的总数</summary>
function Get_CPUCount: Integer;
/// <summary>获取CPU使用率</summary>
function Get_CPUUsage(Index: Integer): Double;
/// <summary>获取CPU制造厂商</summary>
function Get_CPUNo: string;
/// <summary>获取CPU制造厂商</summary>
function Get_CPUVender: string;
/// <summary>获取CPU执行速度</summary>
function Get_CPUSpeed: Double;

{ Net }

/// <summary>获取网卡的 MAC</summary>
function Get_NetMACNo(MethodId: Integer): string;
function Get_NetMACNo1: string;
function Get_NetMACNo2: string;
function Get_NetMACNo3: string;
function Get_NetMACNo4: string;
function Get_NetNames: string;
function Get_NetDescription: string;
function CheckInternet: Boolean;
function Ping(ip: string): Boolean;
function GetLocalIP: string;

{ Display }

/// <summary>获取显卡的刷新率</summary>
function Get_DisplayFrequency: Integer;
/// <summary>获取显卡信息</summary>
function Get_DisplayInfo: string;

{ Other }

/// <summary>返回一个GUID唯一编码</summary>
function GetNewGuid(): TGUID;
/// <summary>返回一个长度为24的唯一编码</summary>
function GetNewID(): string;
/// <summary>返回一个GUID字符串</summary>
function GetGUIDStr(): string;
/// <summary>返回一个GUID</summary>
function GetGUID(): TGUID;
/// <summary>将一个GUID值转换为32字符串</summary>
function GUIDToStr(Guid: TGUID): string;
/// <summary>比较两个GUID值是否一样</summary>
function GuidComp(Guid1, Guid2: TGUID): boolean;
/// <summary>将一个字符串转换为GUID值</summary>
function StrToGUID(S: string): TGUID;
const    //// http://www.buiosch.edu.hk/subjects/maths/PimeGenerator/prime.html
  /// <summary>素数表</summary>
  PrimeNumbers : array[0..255]of UInt64 = (2069,2081,2083,2087,2089,2099,2111,
    2113,2129,2131,2137,2141,2143,2153,2161,2179,2203,2207,2213,2221,2237,2239,
    2243,2251,2267,2269,2273,2281,2287,2293,2297,2309,2311,2333,2339,2341,2347,
    2351,2357,2371,2377,2381,2383,2389,2393,2399,2411,2417,2423,2437,2441,2447,
    2459,2467,2473,2477,2503,2521,2531,2539,2543,2549,2551,2557,2579,2591,2593,
    2609,2617,2621,2633,2647,2657,2659,2663,2671,2677,2683,2687,2689,2693,2699,
    2707,2711,2713,2719,2729,2731,2741,2749,2753,2767,2777,2789,2791,2797,2801,
    2803,2819,2833,2837,2843,2851,2857,2861,2879,2887,2897,2903,2909,2917,2927,
    2939,2953,2957,2963,2969,2971,2999,3001,3011,3019,3023,3037,3041,3049,3061,
    3067,3079,3083,3089,3109,3119,3121,3137,3163,3167,3169,3181,3187,3191,3203,
    3209,3217,3221,3229,3251,3253,3257,3259,3271,3299,3301,3307,3313,3319,3323,
    3329,3331,3343,3347,3359,3361,3371,3373,3389,3391,3407,3413,3433,3449,3457,
    3461,3463,3467,3469,3491,3499,3511,3517,3527,3529,3533,3539,3541,3547,3557,
    3559,3571,3581,3583,3593,3607,3613,3617,3623,3631,3637,3643,3659,3671,3673,
    3677,3691,3697,3701,3709,3719,3727,3733,3739,3761,3767,3769,3779,3793,3797,
    3803,3821,3823,3833,3847,3851,3853,3863,3877,3881,3889,3907,3911,3917,3919,
    3923,3929,3931,3943,3947,3967,3989,4001,4003,4007,4013,4019,4021,4027,4049,
    4051,4057,4073,4079,4091,4093,4099,4111,4127);
/// <summary>根据GUID值定位一个PGuid的Object的ComboBox值</summary>
function IndexOfGuid(AComboBox: TComboBox; G: TGuid): Integer;
/// <summary>乱序一组数字</summary>
/// <param name="FromValue">起始号码</param>
/// <param name="LenBit">长度位数（基数为$100，例如：LenBit=2则长度为$400=1024）</param>
/// <param name="KeyValue">序列密钥</param>
/// <param name="List">乱序数字列表</param>
procedure RandomNums(FromValue: Integer; LenBit, KeyValue: Cardinal;
  List: PArrayInt);
/// <summary>条件返回函数，满足条件返回第一个值，不满足返回第二个值</summary>
function iff(condition: Boolean; A: string; B: string): string;
/// <summary>防止启动第二个进程实体</summary>
procedure CheckPrevInstance(ClassName: string);

/// <summary>根据经纬度计算直线距离函数</summary>
/// <param name="Lon1">本地经度经分</param>
/// <param name="Lonc1">本地经度经分</param>
/// <param name="Lon2">目标地经度经分</param>
/// <param name="Lonc2">目标地经度经分</param>
/// <param name="Lat1">本地的纬度维分</param>
/// <param name="Latc1">本地的纬度维分</param>
/// <param name="Lat2">目标地的纬度维分</param>
/// <param name="Latc2">目标地的纬度维分</param>
function CalcDistance(Lon1: Integer; Lonc1: Double; Lat1: Integer;
  Latc1: Double; Lon2: Integer; Lonc2: Double; Lat2: Integer; Latc2: Double)
  : Double; overload;
/// <summary>根据经纬度计算直线距离函数</summary>
/// <param name="Lon1">本地经度值</param>
/// <param name="Lat1">本地纬度值</param>
/// <param name="Lon2">目标地经度值</param>
/// <param name="Lat2">目标地纬度值</param>
function CalcEarthDistance(Lon1: Double; Lat1: Double; Lon2: Double; Lat2: Double)
  : Double; overload;
/// <summary>根据坐标和日期计算日出时间</summary>
/// <param name="Lon1">经度值</param>
/// <param name="Lat1">纬度值</param>
/// <param name="Date">日期</param>
/// <returns>日出时间</returns>
function CalcSunRaise(Lon1: Double; Lat1: Double; Date: TDate): TDatetime;
/// <summary>根据坐标和日期计算日落时间</summary>
/// <param name="Lon1">经度值</param>
/// <param name="Lat1">纬度值</param>
/// <param name="Date">日期</param>
/// <returns>日落时间</returns>
function CalcSunset(Lon1: Double; Lat1: Double; Date: TDate): TDatetime;

/// <summary>得到该路径和指定后缀的文件列表</summary>
/// <param name="Dir">指定路径</param>
/// <param name="Ext">指定后缀</param>
/// <param name="Items">文件列表</param>
/// <param name="IncludeSubDir">是否包含目录</param>
procedure GetFiles(Dir, Ext: string; Items: TStrings;
  IncludeSubDir: Boolean = false);
/// <summary>得到一个没有文件后缀的文件名</summary>
function GetFileName(Filename: string): string;
/// <summary>复制目录</summary>
procedure DirCopy(ASourceDir:String; ADestDir:String);
/// <summary>创建目录，支持多级目录创建</summary>
procedure CreateDirectory(dir: string);
/// <summary>文件名修改成DOS短文件名(8.3格式)</summary>
function LongToShortFilePath(const LongName: string): string;

(* Component functions *)

/// <summary>字符合法性检验函数</summary>
/// <param name="DataType">字符集名称（INT，Integer，REAL，Float）</param>
/// <param name="Key">检验字符（符合返回本身，否则返回空）</param>
procedure ComponentKeyPress(DataType: string; var Key: Char);
/// <summary>整数Edit录入保护函数</summary>
procedure EventOfIntEditKeyPress(Sender: TEdit; var Key: Char);
/// <summary>浮点Edit录入保护函数</summary>
procedure EventOfFloatEditKeyPress(Sender: TEdit; var Key: Char);
/// <summary>Edit录入框，箭头或回车跳转函数，用于Edit的KeyDown事件</summary>
procedure EventOfMoveEditKeyDown(Sender: TEdit; var Key: Word; Shift: TShiftState);
/// <summary>计算TCheckListBox选择结果以二进制数值表现（bit：0表示没选，1表示选择）</summary>
function GetMutiChkByChkList(AList: TCheckListBox): Int64; overload;
/// <summary>根据记录整数（二进制记忆方式）回选TCheckListBox的内容</summary>
procedure SetMutiChkToChkList(AValue: Int64; AList: TCheckListBox); overload;
/// <summary>计算TCheckListBox选择结果以二进制数值表现（bit：0表示没选，1表示选择）</summary>
procedure GetMutiChkByChkList(var AValue: array of Byte;
  AList: TCheckListBox); overload;
/// <summary>根据记录整数（二进制记忆方式）回选TCheckListBox的内容</summary>
procedure SetMutiChkToChkList(AValue: array of Byte;
  AList: TCheckListBox); overload;
/// <summary>根据选择结果将结果以文字方式显示出来，中间以逗号间隔</summary>
function GetMutiChkString(AList: TCheckListBox): string;
/// <summary>根据字符串记录（中间以逗号间隔）回选TCheckListBox的内容</summary>
procedure SetMutiChkString(AList: TCheckListBox; Value: string);
/// <summary>得到下拉组件中的Object整数值</summary>
function GetListObjectValue(AListBox: TCustomCombo): Integer;
/// <summary>数据库打开后自动整理DBGride列宽</summary>
procedure DBGridAutoFixWidth(objDBGrid: TDBGrid);
/// <summary>播放一段wav格式的声音</summary>
procedure WavBeep(WavFilename: string = '');
/// <summary>直接打印一行内容</summary>
/// <param name="Prn">打印机名称</param>
/// <param name="LineText">打印内容</param>
procedure PrintLine(Prn, LineText: string);

{ checker functions }

/// <summary>检查身份证数据是否有效</summary>
function CheckIdentification(Identification: string): string;
/// <summary>检查银行卡数据是否有效</summary>
function CheckBankCard(BankCard: string): string;
/// <summary>检查集装箱号是否有效</summary>
function CheckContainerNo(ContainerNo: string): string;
/// <summary>检查手机号码是否有效</summary>
function CheckMobile(Mobile: string): string;
/// <summary>检查车牌号码是否有效</summary>
function CheckTrainNo(TrainNo: string): string;

{ multi language }

procedure ReinitializeForms;
function LoadNewResourceModule(Locale: LCID): Longint;

{ 图像处理部分 }

/// <summary>存储多个图像到一个图像文件中</summary>
/// <param name="Filename">文件名称</param>
/// <param name="ImgList">图像列表</param>
procedure SaveImages(FileName: string; ImgList: TImageList);
/// <summary>从一个图像文件中提取多个图像图像列表中</summary>
/// <param name="Filename">文件名称</param>
/// <param name="ImgList">图像列表</param>
procedure LoadImages(FileName: string; ImgList: TImageList; imgHeight: Integer = 0; imgWidth: Integer = 0);
/// <summary>读取一个图像文件到Bitmap控件中</summary>
/// <param name="Filename">文件名称</param>
/// <param name="Bmp">TBitmap图像控件，是返回值</param>
/// <param name="DefineWidth">图像默认宽度，0表示采用原图尺寸</param>
/// <param name="DefineHeight">图像默认高度，0表示采用原图尺寸</param>
procedure LoadGraphicFile(FileName: string; var Bmp: TBitmap;
  DefineWidth: Integer = 0; DefineHeight: Integer = 0); stdcall;
/// <summary>读取资源文件中的位图信息，Image1.Picture.Bitmap.Handle:=GetResBitmap('OPEN');</summary>
function GetResBitmap(const ResName: string): HBitmap;
/// <summary>将Bitmap位图转化为base64字符串</summary>
function BitmapToString(img:TBitmap):string ;
/// <summary>将base64字符串转化为Bitmap位图</summary>
procedure StringToBitmap(imgStr: string; Bmp: TBitmap);
/// <summary>取得系列颜色的下一个颜色</summary>
function NextColor(AColor: TColor = 0; ARate: Extended = 0.618): TColor;
/// <summary>取得颜色上的字体颜色（黑白）</summary>
function FontColor(BackColor: TColor = 0): TColor;

type
  TEventOfLinkTable = function(OrgTable, LinkTable: string): string of object;

  { SQL generator }
function GeneratorSql(Qualifier, Fields: string;
  Event: TEventOfLinkTable): string;
/// <summary>根据设定的条件内容，生成条件语句，&gt;v1,&lt;v2 &gt;=v1,&lt;=v2 v1,v2,v3 (&gt;v1,&lt;v2)|v3 </summary>
function GeneratorCondition(FieldName, Condition: string): string;
/// <summary>为Query添加范围条件</summary>
procedure AddRangeCondition(AQuery: TADOQuery; E1, E2: TCustomEdit;
  FieldName: string); overload;
/// <summary>为Query添加范围条件</summary>
procedure AddRangeCondition(AQuery: TADOQuery; E1, E2: TSpinEdit;
  FieldName: string); overload;
/// <summary>为Query添加范围条件</summary>
procedure AddRangeCondition(AQuery: TADOQuery; E1, E2: TDateTimePicker;
  FieldName: string); overload;
/// <summary>为Query添加范围条件</summary>
procedure AddRangeCondition(AQuery: TADOQuery; Val1, Val2: Extended;
  FieldName: string); overload;

(* DLL API functions *)
function NetWkstaTransportEnum(pszServer: PWideChar; Level: DWORD;
  var pbBuffer: pointer; PrefMaxLen: Longint; var EntriesRead: DWORD;
  var TotalEntries: DWORD; var ResumeHandle: DWORD): DWORD; stdcall;
  external 'NETAPI32.DLL';
function NetApiBufferFree(Buffer: pointer): DWORD; stdcall;
  external 'NETAPI32.DLL';

(* Config file functions *)
type
  /// <summary>录入数据类型</summary>
  /// <param name="LIDT_Text">单行文字录入（TEdit）</param>
  /// <param name="LIDT_Int">整数录入(TSpinEdit)</param>
  /// <param name="LIDT_Float">浮点数据录入（TEdit）</param>
  /// <param name="LIDT_Conn">数据库链接录入(TButtonedEdit)</param>
  /// <param name="LIDT_Date">日期数据录入（TPickDatetime）</param>
  /// <param name="LIDT_Time">时间数据录入（TPickDatetime）</param>
  /// <param name="LIDT_Memo">多行数据录入(TMemo)</param>
  /// <param name="LIDT_RichText">富文本数据录入(FrameRichImputor)</param>
  /// <param name="LIDT_Selection">选择数据录入（TComBoBox）</param>
  /// <param name="LIDT_Choice">单选数据录入(TRadioGroup)</param>
  /// <param name="LIDT_Bool">布尔数据录入(TCheckBox)0：False，1：True</param>
  /// <param name="LIDT_CheckList">复选列表录入(TCheckList)</param>
  /// <param name="LIDT_Bitmap">图片录入(FrameImageImputor)</param>
  /// <param name="LIDT_GUID">GUID生成器(TButtonedEdit)</param>
  /// <param name="LIDT_Dialog">...</param>
  TVonListInputDataType = (LIDT_Text, LIDT_Int, LIDT_Float, LIDT_Conn,
    LIDT_Date, LIDT_Time, LIDT_Memo, LIDT_RichText, LIDT_Selection, LIDT_Choice,
    LIDT_Bool, LIDT_CheckList, LIDT_Bitmap, LIDT_Dialog, LIDT_GUID);
  /// <summary>注册配置文件信息</summary>
  /// <param name="SectionName">段落名称</param>
  /// <param name="IdentName">项目名称</param>
  /// <param name="ConfigInfo">项目说明</param>
  /// <param name="DataType">数据类型<see cref="TVonListInputDataType" /></param>
  /// <param name="Params">参数</param>
  /// <param name="DefaultValue">默认值</param>
procedure RegAppConfig(SectionName, IdentName, ConfigInfo: string;
  DataType: TVonListInputDataType; Params, DefaultValue: string; Help: string = '');
/// <summary>读取配置文件信息</summary>
/// <param name="SectionName">段落名称</param>
/// <param name="IdentName">项目名称</param>
/// <returns>配置内容</returns>
function ReadAppConfig(SectionName, IdentName: string): string;
/// <summary>读取配置配置列表，以逗号间隔</summary>
/// <param name="SectionName">段落名称</param>
/// <param name="IdentName">项目名称</param>
/// <param name="DefauleValue">默认值</param>
/// <param name="Items">列表结果</param>
procedure ReadAppItems(SectionName, IdentName, DefauleValue: string; Items: TStrings);
/// <summary>读取配置参数内容，设置后并返回默认值序号</summary>
/// <param name="SectionName">段落名称</param>
/// <param name="IdentName">项目名称</param>
/// <param name="Items">列表结果</param>
/// <returns>默认配置序号</returns>
function ReadAppSetting(SectionName, IdentName: string; Items: TStrings): Integer;
procedure WriteAppConfig(SectionName, IdentName, Value: string);

(* Runtime functions, Runtime value from SYS_Params *)
procedure RegisteRuntime(Key, Format, DefaultValue: string);
function GetRuntimeValue(Key: string): string;
procedure SetRuntimeValue(Key: string; const Value: string);


(* Internet functions *)
function UrlGetStr(const URL: string; ShowHeaders: Boolean = false): string;


type
  TEventOfString = procedure(Text: string);
  TEventWithNone = procedure();

var
  /// <summary>应用系统配置文件内容列表</summary>
  FAppConfigList: TVonArraySetting;
  /// <summary>系统缓存字符串列表</summary>
  system_temp_string_List: TStringList;
  /// <summary>运行参数设置内容存储变量</summary>
  /// <see cref="EArgumentNilException"/>
  system_runtime_settings: TStringList;
  /// <summary>运行参数值内容存储变量</summary>
  /// <see cref="EArgumentNilException"/>
  system_runtime_value: TStringList;

  FOnSay: TEventOfString;
  FOnStopSay: TEventWithNone;

  FMCI_Handel: Cardinal;

implementation

uses DateUtils;

const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;

var
  FInfoList: TStringList; // 信息记录列表
  FCHMHelpFilename: string;
  FCurrentColor: TColor = $00B3FDDC;

type
  TimeEventClass = class
    FForm: TForm;
    FCount: Integer;
    FCaption: string;
  public
    constructor Create(AForm: TForm; TimeCount: Integer); overload;
    procedure TimeEvent(Sender: TObject);
    procedure EventFormClose(Sender: TObject; var Action: TCloseAction);
  end;

  //***************************************************************
  PIPOptionInformation = ^TIPOptionInformation;
  TIPOptionInformation = packed record
    TTL: Byte;
    TOS: Byte;
    Flags: Byte;
    OptionsSize: Byte;
    OptionsData: PChar;
  end;

  PIcmpEchoReply = ^TIcmpEchoReply;

  TIcmpEchoReply = packed record
    Address: DWORD;
    Status: DWORD;
    RTT: DWORD;
    DataSize: Word;
    Reserved: Word;
    Data: Pointer;
    Options: TIPOptionInformation;
  end;

  TIcmpCreateFile = function: THandle; stdcall;

  TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;

  TIcmpSendEcho = function(IcmpHandle: THandle; DestinationAddress: //
  DWORD; RequestData: Pointer; RequestSize: Word; RequestOptions:  //
  PIPOptionInformation; ReplyBuffer: Pointer; ReplySize: DWord; Timeout: DWord): DWord; stdcall;

{$region 'Ping'}
  Tping = class(Tobject)
    private
  { Private declarations }
      hICMPdll: THANDLE;
      hICMP: THANDLE;
      IcmpCreateFile: TIcmpCreateFile;
      IcmpCloseHandle: TIcmpCloseHandle;
      IcmpSendEcho: TIcmpSendEcho;
    public
//    procedure pinghost(ip: string; var info: string; var IsConnectedOk: Boolean);
    procedure pinghost(ip: string; var IsConnectedOk: Boolean);
    constructor create;
    destructor destroy; override;
  { Public declarations }
  end;

{ Tping }

constructor Tping.create;
begin
  inherited create;
  hICMPdll := LoadLibrary('icmp.dll');
  @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
  @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
  hICMP := IcmpCreateFile;
end;

destructor Tping.destroy;
begin
  FreeLibrary(hIcmpDll);
  inherited destroy;
end;

procedure Tping.pinghost(ip: string; var IsConnectedOk: Boolean);
//procedure Tping.pinghost(ip: string; var info: string; var IsConnectedOk: Boolean);
var
// IP Options for packet to send
  IPOpt: TIPOptionInformation;
  FIPAddress: DWORD;
  pReqData, pRevData: PChar;
// ICMP Echo reply buffer
  pIPE: PIcmpEchoReply;
  FSize: DWORD;
  MyString: string;
  FTimeOut: DWORD;
  BufferSize: DWORD;
  isConnected: Integer;
begin
  if ip <> '' then begin
    // FIPAddress := inet_addr(PChar(ip));//Delphi 7
    IsConnectedOk := False;
    FIPAddress := inet_addr(PAnsiChar(AnsiString(ip)));
    isConnected := 0;
    FSize := 40;
    BufferSize := SizeOf(TICMPEchoReply) + FSize;
    GetMem(pRevData, FSize);
    GetMem(pIPE, BufferSize);
    FillChar(pIPE^, SizeOf(pIPE^), 0);
    pIPE^.Data := pRevData;
    MyString := 'Test Net – Sos Admin';
    pReqData := PChar(MyString);
    FillChar(IPOpt, Sizeof(IPOpt), 0);
    IPOpt.TTL := 64;
    FTimeOut := 1500;  //连接时间，1500MS 1.5S后停止
    try
      isConnected := IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString), //
                @IPOpt, pIPE, BufferSize, FTimeOut);
      if isConnected = 1 then begin
//        info := '连通';
        IsConnectedOk := True;
      end
      else begin
//        info := '不连通';
        IsConnectedOk := False;
      end;
    except
      FreeMem(pRevData);
      FreeMem(pIPE);
      Exit;
    end;
    FreeMem(pRevData);
    FreeMem(pIPE);
  end;
end;

{$endregion}

  { TimeEventClass }

constructor TimeEventClass.Create(AForm: TForm; TimeCount: Integer);
begin
  FForm := AForm;
  FCaption := AForm.Caption;
  FCount := TimeCount;
end;

procedure TimeEventClass.EventFormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  if Assigned(FOnStopSay) then
    FOnStopSay;
  Action := caFree;
end;

procedure TimeEventClass.TimeEvent(Sender: TObject);
begin
  Dec(FCount);
  SysUtils.Beep;
  FForm.Caption := FCaption + '(' + IntToStr(FCount) + ')';
  if FCount > 0 then
    Exit;
  (Sender as TTimer).Enabled := false;
  FForm.Close;
end;

type
  TVendor = array [0 .. 11] of AnsiChar;
  (* Get CPU info *)
  TCPUID = array [1 .. 4] of Longword; // Longint;
  TCPUVendor = array [0 .. 11] of AnsiChar;
  PASTAT = ^TASTAT;

  TASTAT = record
    adapter: TAdapterStatus;
    name_buf: TNameBuffer;
  end;

{$IFNDEF ver110}
{$IFNDEF ver90}
{$IFNDEF ver100}
{$DEFINE UseInt64}
{$ENDIF}
{$ENDIF}
{$IFDEF UseInt64}

type
  TInt64 = Int64;
{$ELSE}

type
  TInt64 = Comp;
{$ENDIF}
{$ELSE}

type
  TInt64 = TLargeInteger;

{$ENDIF}

type
  PInt64 = ^TInt64;

type
  TPERF_DATA_BLOCK = record
    Signature: array [0 .. 4 - 1] of WCHAR;
    LittleEndian: DWORD;
    Version: DWORD;
    Revision: DWORD;
    TotalByteLength: DWORD;
    HeaderLength: DWORD;
    NumObjectTypes: DWORD;
    DefaultObject: Longint;
    SystemTime: TSystemTime;
    Reserved: DWORD;
    PerfTime: TInt64;
    PerfFreq: TInt64;
    PerfTime100nSec: TInt64;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;

  PPERF_DATA_BLOCK = ^TPERF_DATA_BLOCK;

  TPERF_OBJECT_TYPE = record
    TotalByteLength: DWORD;
    DefinitionLength: DWORD;
    HeaderLength: DWORD;
    ObjectNameTitleIndex: DWORD;
    ObjectNameTitle: LPWSTR;
    ObjectHelpTitleIndex: DWORD;
    ObjectHelpTitle: LPWSTR;
    DetailLevel: DWORD;
    NumCounters: DWORD;
    DefaultCounter: Longint;
    NumInstances: Longint;
    CodePage: DWORD;
    PerfTime: TInt64;
    PerfFreq: TInt64;
  end;

  PPERF_OBJECT_TYPE = ^TPERF_OBJECT_TYPE;

type
  TPERF_COUNTER_DEFINITION = record
    ByteLength: DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle: LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle: LPWSTR;
    DefaultScale: Longint;
    DetailLevel: DWORD;
    CounterType: DWORD;
    CounterSize: DWORD;
    CounterOffset: DWORD;
  end;

  PPERF_COUNTER_DEFINITION = ^TPERF_COUNTER_DEFINITION;

  TPERF_COUNTER_BLOCK = record
    ByteLength: DWORD;
  end;

  PPERF_COUNTER_BLOCK = ^TPERF_COUNTER_BLOCK;

  TPERF_INSTANCE_DEFINITION = record
    ByteLength: DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance: DWORD;
    UniqueID: Longint;
    NameOffset: DWORD;
    NameLength: DWORD;
  end;

  PPERF_INSTANCE_DEFINITION = ^TPERF_INSTANCE_DEFINITION;

{$IFDEF ver130}
{$L-} // The L+ causes internal error in Delphi 5 compiler
{$O-} // The O+ causes internal error in Delphi 5 compiler
{$Y-} // The Y+ causes internal error in Delphi 5 compiler
{$ENDIF}
{$IFNDEF ver110}

type
  TInt64F = TInt64;
{$ELSE}

type
  TInt64F = Extended;
{$ENDIF}
{$IFDEF ver110}

function FInt64(Value: TInt64): TInt64F;
  function Int64D(Value: DWORD): TInt64;
{$ELSE}
type
  FInt64 = TInt64F;
  Int64D = TInt64;
{$ENDIF}
{$IFDEF ver110}

function FInt64(Value: TInt64): TInt64F;
var
  V: TInt64;
begin
  if (Value.HighPart and $80000000) = 0 then // positive value
  begin
    result := Value.HighPart;
    result := result * $10000 * $10000;
    result := result + Value.LowPart;
  end
  else
  begin
    V.HighPart := Value.HighPart xor $FFFFFFFF;
    V.LowPart := Value.LowPart xor $FFFFFFFF;
    result := -1 - FInt64(V);
  end;
end;

function Int64D(Value: DWORD): TInt64;
begin
  result.LowPart := Value;
  result.HighPart := 0; // positive only
end;
{$ENDIF}

const
  Processor_IDX_Str = '238';
  Processor_IDX = 238;
  CPUUsageIDX = 6;

type
  AInt64F = array [0 .. $FFFF] of TInt64F;
  PAInt64F = ^AInt64F;

var
  _PerfData: PPERF_DATA_BLOCK;
  _BufferSize: Integer;
  _POT: PPERF_OBJECT_TYPE;
  _PCD: PPERF_COUNTER_DEFINITION;
  _ProcessorsCount: Integer;
  _Counters: PAInt64F;
  _PrevCounters: PAInt64F;
  _SysTime: TInt64F;
  _PrevSysTime: TInt64F;
  _IsWinNT: Boolean;

  _W9xCollecting: Boolean;
  _W9xCpuUsage: DWORD;
  _W9xCpuKey: HKEY;
  VI: TOSVERSIONINFO;

  { Math.String }

function Space(Count: Integer = 1; Ch: Char = ' '): string;
var
  P: PAnsiChar;
begin
  GetMem(P, Count + 1);
  FillChar(P[0], Count, Ch);
  P[Count] := #0;
  result := string(P);
end;
/// <summary>生成随机字母</summary>
function RandomStr(Count: Integer; includeUpper, includeLower, IncludeNum, includeSpeical: Boolean): string;
const SPEICAL_CHAR : string = '~!@#$%^&*()_+=-`[]\\{}|; :",./<>?';
var                         // 12345678901234567890123456789012
  i, MaxRange, val: Integer;
begin
  MaxRange:= 0; Result:= '';
  if includeUpper then Inc(MaxRange, 26);
  if includeLower then Inc(MaxRange, 26);
  if IncludeNum then Inc(MaxRange, 10);
  if includeSpeical then Inc(MaxRange, 32);
  for I := 1 to Count do begin
    val:= Random(MaxRange) + 1;
    if includeUpper and (val > 0) then begin
      if val <= 26 then Result:= Result + Char(Ord('A') + val - 1);
      Dec(val, 26);
    end;
    if includeLower and (val > 0) then begin
      if val <= 26 then Result:= Result + Char(Ord('a') + val - 1);
      Dec(val, 26);
    end;
    if IncludeNum and (val > 0) then begin
      if val <= 10 then Result:= Result + Char(Ord('0') + val - 1);
      Dec(val, 10);
    end;
    if includeSpeical and (val > 0) and (val <= 32) then
      Result:= Result + SPEICAL_CHAR.Chars[val];
  end;
end;

function BIG5ToGB(Str: string): string; // 繁->简
  function UnicodeEncode(Str: string; CodePage: Integer): WideString;
  var
    len: Integer;
  begin
    len := length(Str) + 1;
    SetLength(result, len);
    len := MultiByteToWideChar(CodePage, 0, PAnsiChar(Str), -1,
      PWideChar(result), len);
    SetLength(result, len - 1); // end is #0
  end;
  function UnicodeDecode(Str: WideString; CodePage: Integer): string;
  var
    len: Integer;
  begin
    len := length(Str) * 2 + 1; // one for #0
    SetLength(result, len);
    len := WideCharToMultiByte(CodePage, 0, PWideChar(Str), -1,
      PAnsiChar(result), len, nil, nil);
    SetLength(result, len - 1);
  end;

begin
  Str := UnicodeDecode(UnicodeEncode(Str, 950), 936);
  SetLength(result, length(Str));
  LCMapString(GetUserDefaultLCID, LCMAP_SIMPLIFIED_CHINESE, PChar(Str),
    length(Str), PChar(result), length(result));
end;

function GBToBIG5(Str: string): string; // 简->繁
  function UnicodeEncode(Str: string; CodePage: Integer): WideString;
  var
    len: Integer;
  begin
    len := length(Str) + 1;
    SetLength(result, len);
    len := MultiByteToWideChar(CodePage, 0, PAnsiChar(Str), -1,
      PWideChar(result), len);
    SetLength(result, len - 1); // end is #0
  end;
  function UnicodeDecode(Str: WideString; CodePage: Integer): string;
  var
    len: Integer;
  begin
    len := length(Str) * 2 + 1; // one for #0
    SetLength(result, len);
    len := WideCharToMultiByte(CodePage, 0, PWideChar(Str), -1,
      PAnsiChar(result), len, nil, nil);
    SetLength(result, len - 1);
  end;

// ******
begin
  SetLength(result, length(Str));
  LCMapString(GetUserDefaultLCID, LCMAP_TRADITIONAL_CHINESE, PChar(Str),
    length(Str), PChar(result), length(result));
  result := UnicodeDecode(UnicodeEncode(result, 936), 950);
end;
/// Wide String -> Ansi String
function WideStringToAnsiString(const strWide: WideString; CodePage: Word): AnsiString;
var
  Len: integer;
begin
  Result := '';
  if strWide = '' then Exit;

  Len := WideCharToMultiByte(CodePage,
    WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
    @strWide[1], -1, nil, 0, nil, nil);
  SetLength(Result, Len - 1);

  if Len > 1 then
    WideCharToMultiByte(CodePage,
      WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
      @strWide[1], -1, @Result[1], Len - 1, nil, nil);
end;

/// Ansi String -> Wide String
function AnsiStringToWideString(const strAnsi: AnsiString; CodePage: Word): WideString;
var
  Len: integer;
begin
  Result := '';
  if strAnsi = '' then Exit;

  Len := MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PAnsiChar(@strAnsi[1]), -1, nil, 0);
  SetLength(Result, Len - 1);

  if Len > 1 then
    MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PAnsiChar(@strAnsi[1]), -1, PWideChar(@Result[1]), Len - 1);
end;

{$I SpellConst.inc}

function SimpleAddress(Str: string): string;
const Determiners = '省市县区郊乡镇旗盟党所';
var
  P: PChar;
begin
  result:= ''; P:= PChar(Str);
  while P^ <> #0 do begin
    if Pos(P^, Determiners) > 0 then result:= ''
    else result:= result + P^;
    Inc(P);
  end;
end;

function FindSpell(Ch: Char): Integer;
var
  Idx1, Idx2, Idx, cnt: Integer;
begin
  result := -1;
  if Pos(Ch, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0987654321') > 0 then begin
    Result:= -1;
    Exit;
  end;
  if Pos(Ch, ' ~`@#$%^&*()_+-={}|[]\:";''<>?,./　～！＠＃￥％……＆×（）——＋＝－０９８７６５４３２１·ｑｗｅｒｔｙｕｉｏｐ［］＼｜｝｛ａｓｄｆｇｈｊｋｌ；＇＂：／．，ｍｎｂｖｃｘｚ＜＞？ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ') > 0 then Exit;
  if(HZSet[0] > ch)or(HZSet[HZCount - 1] < ch)then Exit;
  cnt:= 0;
  Idx1:= 0;
  Idx2:= HZCount - 1;
  Idx:= Round(HZCount * 0.618);
  while(HZSet[Idx] <> ch)and(Idx1 <> Idx2) do begin        //)and(ABS(Idx1 - Idx2) > 1
    if Ord(ch) > Ord(HZSet[Idx]) then
      Idx1:= Idx + 1
    else Idx2:= Idx - 1;
    Idx:= Round((Idx2 - Idx1) * 0.618 + Idx1);
    Inc(cnt);
    if cnt > 20 then Break;
  end;
  if HZSet[Idx] <> ch then result := -1
  else result := Idx;
end;

function SpellChar(Ch: Char): string;
var
  Idx: Integer;
begin
  Idx:= FindSpell(Ch);
  if Idx >= 0 then Result:= WDSet[Idx]
  else Result:= Ch;
end;

function FullSpellString(Str: string): string;
var
  Idx, chID, mPos: Integer;
  szS: string;
begin
  result := '';
  for Idx := 1 to length(Str) do
  begin
    chID:= FindSpell(Str[Idx]);
    if chID < 0 then szS:= Str[Idx]
    else szS := PYSet[chID];
    mPos := Pos(' ', szS);
    if mPos > 0 then
      result := result + ' ' + Copy(szS, 1, mPos - 1)
    else
      result := result + ' ' + szS;
  end;
end;

function SimpleSpellString(Str: string): string;
var
  Idx, mPos: Integer;
  szS: string;
begin
  result := '';
  for Idx := 1 to length(Str) do
  begin
    szS := SpellChar(Str[Idx]);
    mPos := Pos(' ', szS);
    if mPos > 0 then
      result := result + ' ' + Copy(szS, 1, mPos - 1)
    else
      result := result + ' ' + szS;
  end;
end;

function AlphabetSpellString(Str: string): string;
var
  Idx, I: Integer;
  szS: string;
begin
  result := '';
  for Idx := 1 to length(Str) do
  begin
    szS := SpellChar(Str[Idx]);
    for I := 1 to Length(szS) do
      if Pos(szS[I], '1234567890 ') > 0 then break
      else result := result + szS[I];
  end;
end;

function ShortSpellString(Str: string): string;
var
  Idx: Integer;
  szS: string;
begin
  result := '';
  for Idx := 1 to length(Str) do
  begin
    szS := SpellChar(Str[Idx]);
    if szS <> '' then
      result := result + szS[1];
  end;
end;

function HexToInt(Str: string): Int64;
var
  S: string;
begin
  result := 0;
  if Str = '' then Exit;
  S := Str;
  if S[1] <> '$' then
    S := '$' + S;
  result := StrToInt64Def(S, 0);
end;

function IntToHex(Value: Int64): string;
begin
  result := IntToHex(Value, 16);
  while (result[1] = '0') and (length(result) > 1) do
    Delete(result, 1, 1);
end;

function IntToHex(Value: Integer): string;
begin
  result := IntToHex(Value, 8);
  while (result[1] = '0') and (length(result) > 1) do
    Delete(result, 1, 1);
end;

function StrToHex(AStr: string): string; // 字符转化成十六进制
  function TransChar(AChar: Char): Integer;
  begin
    if AChar in ['0' .. '9'] then
      result := Ord(AChar) - Ord('0')
    else
      result := 10 + Ord(AChar) - Ord('A');
  end;

var
  I: Integer;
  CharValue: word;
begin
  result := '';
  for I := 1 to Trunc(length(AStr) / 2) do
  begin
    result := result + ' ';
    CharValue := TransChar(AStr[2 * I - 1]) * 16 + TransChar(AStr[2 * I]);
    result[I] := Char(CharValue);
  end;
end;

function HexToStr(AStr: string): string; // 十六进制转化成字符
var
  I: Integer;
begin
  result := '';
  for I := 1 to length(AStr) do
  begin
    result := result + Format('%2x', [Byte(AStr[I])]);
  end;
  I := Pos(' ', result);
  while I <> 0 do
  begin
    result[I] := '0';
    I := Pos(' ', result);
  end;
end;

function IntToBin(TheVal: Longint; const Count: Integer = 0): string;
var
  counter: Longword;
begin
  if TheVal = 0 then
  begin
    result := '0';
    Exit;
  end;
  result := '';
  counter := $80000000;
  while ((counter and TheVal) = 0) do
  begin
    counter := counter shr 1;
    if (counter = 0) then
      break;
  end;

  while counter > 0 do
  begin
    if (counter and TheVal) = 0 then
      result := result + '0'
    else
      result := result + '1';
    counter := counter shr 1;
  end;
  result := StringOfChar('0', Count - length(result)) + result;
end;

// 十进制转二进制
function BinToInt(S: string): Integer; // 二进制转十进制
var
  V: Real;
  len, n, I: Integer;
begin
  V := 0;
  len := length(S);
  for I := len downto 1 do
  begin
    if S[I] = '1' then
      n := 1
    else
      n := 0;
    V := V + Exp(ln(2) * (len - I)) * n;
  end;
  result := Trunc(V);
end;

function IntToCol(Idx: Integer): string;
begin
  result := '';
  while Idx >= 0 do begin
    result := Char(Idx mod 26 + 65) + result;
    Idx := (Idx div 26) - 1;
  end;
end;

function ColToInt(ColName: string): Integer;
var
  I: Integer;
begin
  result := 0;
  for I := 1 to length(ColName) do
    result := result * 26 + Ord(ColName[I]) - Ord('A');
end;

function GetCellName(Page, Col, Row: Integer): string;
var
  S: string;
begin // <Page><ColName><Row>
  // Inc(Page);
  Dec(Col);
  if Page = 0 then result := ''
  else result := IntToStr(Page);
  while Col > 26 do
  begin
    result := result + Char(Ord('A') + Col mod 26);
    Col := Col div 26;
  end;
  result := result + Char(Ord('A') + Col mod 26) + IntToStr(Row);
end;

function SplitCellName(CellName: PChar; var Page, Col, Row: Integer): Boolean;
begin // Cell name <pageIdx><ColName><Row> 例如: 3D3 = 第3页 d（4）列 3行
  Row := 0;
  Col := 0;
  Page := 0;
  while (CellName^ >= '0') and (CellName^ <= '9') do
  begin // Read page value
    Page := Page * 10 + Ord(CellName^) - Ord('0');
    Inc(CellName);
  end;
  result := (CellName^ >= 'A') and (CellName^ <= 'Z');
  if not result then
    Exit;
  while (CellName^ >= 'A') and (CellName^ <= 'Z') do
  begin // Read col value
    Col := Col * 26 + Ord(CellName^) - Ord('A');
    Inc(CellName);
  end;
  while (CellName^ >= '0') and (CellName^ <= '9') do
  begin // Read page value
    Row := Row * 10 + Ord(CellName^) - Ord('0');
    Inc(CellName);
  end;
  Inc(Col);
end;

function IntToCnSerial(Idx: Integer): string;
const CnSerial = '甲乙丙丁戊己庚辛壬癸';
begin
  result := '';
  while Idx > 0 do begin
    result := CnSerial[Idx mod 10 + 1] + result;
    Idx := Idx div 10;
  end;
end;

function HexToBin(AStr: string): string; // 十六进制转二进制
  function TransChar(AChar: Char): Integer;
  begin
    if AChar in ['0' .. '9'] then
      result := Ord(AChar) - Ord('0')
    else
      result := 10 + Ord(AChar) - Ord('A');
  end;

var
  I: Integer;
  CharValue: word;
begin
  result := '';
  for I := 1 to Trunc(length(AStr) / 2) do
  begin
    result := result + ' ';
    CharValue := TransChar(AStr[2 * I - 1]) * 16 + TransChar(AStr[2 * I]);
    result[I] := Char(CharValue);
  end;
end;

function IntToBCD(value: Int64): TBytes;
var
  I: Integer;
begin
  SetLength(Result, Round(Log10(value) + 1));
  I:= 0;
  while value > 0 do begin
    Result[I]:= value mod 10;
    value:= Trunc(value / 10);
    Inc(I);
  end;
end;

procedure VarToArray(DBBinary: Variant; value: TBytes; len: Integer);
var
  PData : PByte;
  I: Integer;
begin
  PData := VarArrayLock(DBBinary);
  try
    FillChar(value, len, #0);
    for I := 0 to Min(len, SizeOf(PData)) - 1 do
      value[I]:= PData[I];
  finally
    VarArrayUnlock(DBBinary);
  end;
end;

function BCDToInt(BCD: Byte): Word;
begin
  Result:= (BCD shr 4)*10 + (BCD and $0F)
end;

function BcdsToInt(BCDs: TBytes): Int64;
var
  I, rate: Integer;
begin
  Result:= 0;
  rate:= 1;
  for I := 0 to Length(BCDs) - 1 do begin
    Result:= Result + ((BCDs[I] shr 4)*10 + (BCDs[I] and $0F)) * rate;
    rate:= rate * 10;
  end;
end;

function GB2UniCode(GB: string): string;
var
  s: string;
  i, j, k: integer;
  a: array [1..160] of char;
begin
  s:='';
  StringToWideChar(GB, @(a[1]), 500);
  i:= 1;
  while ((a[i] <> #0) or (a[i+1] <> #0)) do begin
    j:= Integer(a[i]);
    k:= Integer(a[i + 1]);
    s:= s + Copy(Format('%X ', [k * $100 + j + $10000]), 2, 4);
    i:= i + 2;
  end;
  Result:=s;
end;

function UniCode2GB(const AStr: AnsiString): AnsiString;
// The NoConversion set contains characters as specificed in RFC 1738 and
// should not be modified unless the standard changes.
const
  NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-',
                  '0'..'9','$','!','''','(',')'];
var
  Sp, Rp: PAnsiChar;
begin
  SetLength(Result, Length(AStr) * 3);
  Sp := PAnsiChar(AStr);
  Rp := PAnsiChar(Result);
  while Sp^ <> #0 do
  begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else
      if Sp^ = ' ' then
        Rp^ := '+'
      else
      begin
        FormatBuf(Rp^, 3, AnsiString('%%%.2x'), 6, [Ord(Sp^)]);
        Inc(Rp,2);
      end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PAnsiChar(Result));
end;

function BytesToHex(Bs: array of byte; Len: Integer): string;
var
  I: Integer;
begin
  Result:= IntToHex(Bs[0]);
  for I := 1 to Len - 1 do
    Result:= Result + ' ' + IntToHex(Bs[I]);
end;

function UpperNum(Value: Double): string;
const
  s1: string = '零壹贰叁肆伍陆柒捌玖';
  s2: string = '点拾佰仟万拾佰仟亿拾佰仟万';
var
  s, dx: string;
  i, Len, zeroPos: Integer;

  function StrTran(const S, S1, S2: String): String;
  begin
    Result := StringReplace(S, S1, S2, [rfReplaceAll]);
  end;
begin
  if Value < 0 then begin
    dx:= '负';
    Value:= -Value;
  end else dx:= '';
  s:= FloatToStr(Value);         //123.234
  zeroPos:= Pos('.', s);             //1234567
  Len:= Length(s);
  if zeroPos = 0 then zeroPos:= Len + 1;
  for i := 1 to zeroPos - 1 do
    dx := dx + s1[Ord(s[i]) - Ord('0') + 1] + s2[zeroPos - i];
  dx := StrTran(StrTran(StrTran(dx, '零仟', '零'), '零佰', '零'), '零拾', '零');
  dx := StrTran(StrTran(StrTran(StrTran(dx, '零零', '零'), '零零', '零'), '零亿', '亿'), '零万', '万');
  for i := zeroPos + 1 to Len do
    dx := dx + s1[Ord(s[i]) - Ord('0') + 1];
  if Copy(dx, 1, 4) = '壹拾' then Delete(dx, 1, 2);
  if dx = '零点' then dx:= '零' else dx:= StrTran(dx, '零点', '点');
  if Copy(dx, Length(dx) - 1, 2) = '点' then Delete(dx, Length(dx) - 1, 2);
  Result := StrTran(dx, '亿万', '亿');
end;

function UpperCash(Value: Double): string;
const
  s1: string = '零壹贰叁肆伍陆柒捌玖';
  s2: string = '分角元拾佰仟万拾佰仟亿拾佰仟万';
var
  s, dx: string;
  i, Len: Integer;

  function StrTran(const S, S1, S2: String): String;
  begin
    Result := StringReplace(S, S1, S2, [rfReplaceAll]);
  end;
begin
  if Value < 0 then begin
    dx:= '负';
    Value:= -Value;
  end else dx:= '';
  s:= Format('%.0f', [Value * 100]);
  Len:= Length(s);
  for i := 1 to Len do
    dx := dx + s1[(Ord(s[i]) - Ord('0')) + 1] + s2[(Len - i) + 1];
    dx := StrTran(StrTran(StrTran(StrTran(StrTran(dx, '零仟', '零'), '零佰', '零'), '零拾', '零'), '零角', '零'), '零分', '整');
    dx := StrTran(StrTran(StrTran(StrTran(StrTran(dx, '零零', '零'), '零零', '零'), '零亿', '亿'), '零万', '万'), '零元', '元');
  if dx = '整' then Result := '零元整'
  else Result := StrTran(StrTran(dx, '亿万', '亿'), '零整', '整');
end;

function UpperDigit(Value: Double): string;
const
  s1: string = '〇一二三四五六七八九';
var
  s, dx: string;
  i, Len: Integer;
begin
  if Value < 0 then begin
    dx:= '负';
    Value:= -Value;
  end;
  s:= FloatToStr(Value);
  Len:= Length(s);
  for i := 1 to Len do
    if s[i] = '.' then dx := dx + '点'
    else dx := dx + Copy(s1, (Ord(s[i]) - Ord('0')) * 2 + 1, 2);
  Result:= dx;
end;

function ColorToWebColor(Color: TColor): string;
var
  rgbColor: Cardinal;
begin
  if Color < 0 then
    result := IntToHex(GetSysColor(Color and $000000FF), 6)
  else
    result := IntToHex(Color, 6);
  if length(result) > 6 then
    Delete(result, 1, length(result) - 6);
  result := '#' + result[5] + result[6] + result[3] + result[4] + result[1] +
    result[2];
end;

function DateTimeToCrcString(DT: TDatetime): string;
var
  AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: word;
begin
  DecodeDateTime(DT, AYear, AMonth, ADay, AHour, AMinute, ASecond,
    AMilliSecond);
  if AMilliSecond > 500 then
    result := FormatDatetime('yyyymmdd', IncSecond(EncodeDateTime(AYear, AMonth,
      ADay, AHour, AMinute, ASecond, 0), 1))
  else
    result := FormatDatetime('yyyymmdd', EncodeDateTime(AYear, AMonth, ADay,
      AHour, AMinute, ASecond, 0));
end;

function CrcStringToDatetime(S: string): TDatetime;
var
  AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: word;
begin
  AYear := 0;
  AMonth := 0;
  ADay := 0;
  AHour := 0;
  AMinute := 0;
  ASecond := 0;
  AMilliSecond := 0;
  if length(S) > 7 then
  begin // yyyymmdd
    AYear := StrToInt(Copy(S, 1, 4));
    AMonth := StrToInt(Copy(S, 5, 2));
    ADay := StrToInt(Copy(S, 7, 2));
  end;
  if length(S) > 9 then // yyyymmddhh
    AHour := StrToInt(Copy(S, 9, 2));
  if length(S) > 11 then // yyyymmddhhnn
    AMinute := StrToInt(Copy(S, 11, 2));
  if length(S) > 13 then // yyyymmddhhnnss
    ASecond := StrToInt(Copy(S, 13, 2));
  if length(S) > 15 then // yyyymmddhhnnsszzz
    AMilliSecond := StrToInt(Copy(S, 15, MaxInt));
end;

/// <summary>计算当前年龄</summary>
function Age(DT: TDatetime): integer;
var
  Y1, Y2, M1, M2, D1, D2: word;
begin
  DecodeDate(Now, Y1, M1, D1);
  DecodeDate(DT, Y2, M2, D2);
  Result:= Y1 - Y2;
  if((M1 - M2) = 0)and((D1 - D2) < 0)then Result:= Result - 1;
  if (M1 - M2) < 0 then Result:= Result - 1;
end;

/// <summary>将一个字符串写入流</summary>
procedure WriteStringToStream(S: string; st: TStream);
var
  szBytes: TBytes;
  ln: Integer;
begin
  szBytes := TEncoding.Unicode.GetBytes(S);
  ln := TEncoding.Unicode.GetByteCount(S);
  st.Write(ln, 4);
  st.Write(szBytes[0], ln);
  SetLength(szBytes, 0);
end;

procedure WriteByteToStream(val: Byte; st: TStream);
begin
  st.Write(val, 2);
end;

procedure WriteIntToStream(val: Integer; st: TStream);
begin
  st.Write(val, 4);
end;

procedure WriteInt64ToStream(val: Int64; st: TStream);
begin
  st.Write(val, 8);
end;

procedure WriteExtendedToStream(val: Extended; st: TStream);
begin
  st.Write(val, 10);
end;

procedure WriteDoubleToStream(val: Double; st: TStream);
begin
  st.Write(val, 8);
end;

procedure WriteGuidToStream(val: TGuid; st: TStream);
begin
  st.Write(val, SizeOf(TGuid));
end;

procedure WriteStreamToStream(Src, Dest: TStream);
var
  ln: Int64;
begin
  ln := Src.Size;
  Dest.Write(ln, 8);
  Src.Position := 0;
  Dest.CopyFrom(Src, ln);
end;

/// <summary>从流的当前位置读取一个字符串信息</summary>
function ReadStringFromStream(st: TStream): string;
var
  szBytes: TBytes;
  ln: Integer;
begin
  Result:= '';
  st.Read(ln, 4);
  if ln = 0 then Exit;
  SetLength(szBytes, ln);
  st.Read(szBytes[0], ln);
  result := TEncoding.Unicode.GetString(szBytes);
  SetLength(szBytes, 0);
end;

function ReadByteFromStream(st: TStream): Byte;
begin
  st.Read(result, 2);
end;

function ReadIntFromStream(st: TStream): Integer;
begin
  st.Read(result, 4);
end;

function ReadInt64FromStream(st: TStream): Int64;
begin
  st.Read(result, 8);
end;

function ReadExtendedFromStream(st: TStream): Extended;
begin
  st.Read(result, 10);
end;

function ReadDoubleFromStream(st: TStream): Double;
begin
  st.Read(result, 8);
end;

function ReadGuidFromStream(st: TStream): TGuid;
begin
  st.Read(result, SizeOf(TGuid));
end;

procedure ReadStreamFromStream(Src, Dest: TStream);
var
  ln: Int64;
begin
  Src.Read(ln, 8);
  Dest.CopyFrom(Src, ln);
end;

function BytesToStr(bytes: array of byte; Start, len: Integer): string;
var
  Bs: TBytes;
begin
  SetLength(Bs, Len);
  Move(bytes[Start], Bs[0], Len);
  Result:= TEncoding.Default.GetString(Bs);
end;

function StrToBytes(S: string; var bytes: array of byte; Size: Integer): Integer;
var
  Bs: TBytes;
begin
  Bs:= TEncoding.Default.GetBytes(S);
  Result:= Min(Length(Bs), Size);
  Move(Bs[0], bytes, Result);
end;

procedure ReadZipFile(FileName: string; st: TStream);
var
  szStream: TFileStream;
begin
  szStream := TFileStream.Create(FileName, fmOpenRead);
  ZDecompressStream(szStream, st);
  st.Position := 0;
  szStream.Free;
end;

procedure ReadStringsFromZipFile(FileName: string; st: TStringList);
var
  szStream: TMemoryStream;
begin
  szStream := TMemoryStream.Create;
  ReadZipFile(FileName, szStream);
  st.LoadFromStream(szStream);
  szStream.Free;
end;

procedure WriteZipFile(FileName: string; st: TStream);
var
  szStream: TFileStream;
begin
  szStream := TFileStream.Create(FileName, fmCreate);
  st.Position := 0;
  ZCompressStream(st, szStream, zcDefault);
  szStream.Free;
end;

procedure WriteStringsToZipFile(FileName: string; st: TStringList);
var
  szStream: TMemoryStream;
begin
  szStream := TMemoryStream.Create;
  st.SaveToStream(szStream);
  WriteZipFile(FileName, szStream);
  szStream.Free;
end;

function SplitStr(Str, Delimiter: string): TStringList;
begin
  system_temp_string_List.Text := ReplaceText(Str, Delimiter, #13#10);
  result := system_temp_string_List;
end;

function SplitStr(Str, Delimiters: string; IncludeNull: boolean): TStringList;
var
  szS: string;
  P: PChar;
begin
  P:= PChar(Str);
  system_temp_string_List.Clear;
  while P^ <> #0 do begin
    if(Pos(P^, Delimiters) > 0)then begin
      szS:= Trim(szS);
      if IncludeNull or(szS <> '')then begin
        system_temp_string_List.Add(szS);
        szS:= '';
      end;
    end else szS:= szS + P^;
    Inc(P);
  end;
  if IncludeNull or(szS <> '')then
    system_temp_string_List.Add(szS);
  Result:= system_temp_string_List;
end;

function SplitStr(Str: string; ArrValue: array of string; Delimiter: string = ','): Boolean;
var
  P: PChar;
  Idx: Integer;
begin
  Result:= False;
  if Str = '' then Exit;
  P:= PChar(Str);
  for Idx:= 0 to Length(ArrValue) - 1 do
    ArrValue[Idx]:= '';
  Idx:= 0;
  while P^ <> #0 do begin
    if P^ = Delimiter then begin
      Inc(Idx);
      if Idx >= Length(ArrValue) then Exit;
    end else ArrValue[Idx]:= ArrValue[Idx] + P^;
    Inc(P);
  end;
  Result:= True;
end;

{ Application and operation system }

function IsAdmin: Boolean;
var
  hAccessToken: THandle;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWORD;
  psidAdministrators: PSID;
  x: Integer;
  bSuccess: Bool;
begin
  result := false;
  bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
    hAccessToken);
  if not bSuccess then
  begin
    if GetLastError = ERROR_NO_TOKEN then
      bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
        hAccessToken);
  end;
  if bSuccess then
  begin
    GetMem(ptgGroups, 1024);
    bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024,
      dwInfoBufferSize);
    CloseHandle(hAccessToken);
    if bSuccess then
    begin
      AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
        SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0,
        psidAdministrators);
{$R-}
      for x := 0 to ptgGroups.GroupCount - 1 do
        if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
        begin
          result := True;
          break;
        end;
    end;
{$R+}
    FreeSid(psidAdministrators);
  end;
  FreeMem(ptgGroups);
end;

function Get_WindowsLanguage: string;
var
  WinLanguage: array [0 .. 50] of Char;
begin
  VerLanguageName(GetSystemDefaultLangID, WinLanguage, 50);
  result := StrPas(WinLanguage);
end;

function Get_WindowsLanguage(LCTYPE: LCTYPE): string;
var
  Buffer: PChar;
  Size: Integer;
begin
  Size := GetLocaleInfo(LOCALE_USER_DEFAULT, LCTYPE, nil, 0);
  GetMem(Buffer, Size);
  try
    GetLocaleInfo(LOCALE_USER_DEFAULT, LCTYPE, Buffer, Size);
    result := string(Buffer);
  finally
    FreeMem(Buffer);
  end;
end;

function Get_OSVersionText: string;
var
  Info: TOSVERSIONINFO;
  S: string;
begin
  result := '';
  FillChar(Info, SizeOf(TOSVERSIONINFO), 0);
  Info.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
  if (not GetVersionEx(Info)) then
    Exit;
  case Info.dwPlatformId of
    VER_PLATFORM_WIN32s:
      S := 'WIN32s';
    VER_PLATFORM_WIN32_WINDOWS:
      S := 'WIN32_WINDOWS';
    VER_PLATFORM_WIN32_NT:
      S := 'VWIN32_NT';
    VER_PLATFORM_WIN32_CE:
      S := 'VWIN32_CE';
  end;
  // S:= GetEnvironmentVariable('OS');
  result := Format('操作系统：%s 版本:%d.%d.%d.%d %s', [S, Info.dwMajorVersion,
    Info.dwMajorVersion, Info.dwMinorVersion, Info.dwBuildNumber,
    string(Info.szCSDVersion)]);
end;

function Get_ApplicationVersion(AppFilename: string): string;
var
  S: string;
  n, len: Cardinal;
  Buf: PChar;
  Vervalue: PVSFixedFileInfo;
  V1, V2, V3, V4: word;
begin
  result := '';
  S := AppFilename;
  n := GetFileVersionInfoSize(PChar(S), n);
  if n > 0 then
  begin
    Buf := AllocMem(n);
    GetFileVersionInfo(PChar(S), 0, n, Buf);
    if VerQueryValue(Buf, '\', pointer(Vervalue), len) then
      with Vervalue^ do
      begin
        V1 := dwFileVersionMS shr 16;
        V2 := dwFileVersionMS and $FFFF;
        V3 := dwFileVersionLS shr 16;
        V4 := dwFileVersionLS and $FFFF;
      end;
    result := IntToStr(V1) + '.' + IntToStr(V2) + '.' + IntToStr(V3) + '.' +
      IntToStr(V4); // 040904E4
    FreeMem(Buf, n);
  end;
end;
//开启服务
function StartService(const sServiceName: string): Boolean;
var
  hService, hSCManager: SC_HANDLE;
  SS: TServiceStatus; arg: PChar;
begin
  hSCManager:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if hSCManager = 0 then
  begin
    result := false;
    exit;
  end;
  hService := OpenService(hSCManager, PChar(sServiceName), SERVICE_ALL_ACCESS);
  if hService = 0 then
  begin
    CloseServiceHandle(hSCManager);
    result := false;
    exit;
  end;
  try
    Result := WinSVC.StartService(hService, 0, arg);
    CloseServiceHandle(hService);
    CloseServiceHandle(hSCManager);
  except
    showmessage('Auto Start Error');
    CloseServiceHandle(hService);
    CloseServiceHandle(hSCManager);
    Exit;
  end;
//var
//  SCH, SvcSCH: SC_HANDLE;
//  arg: PChar;
//  dwStartType: DWORD;
//begin
//  Result := False;
//  SCH := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_CONNECT);//OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
//  if SCH <= 0 then Exit;
//  SvcSCH := OpenService(SCH, PChar(SvrName), SERVICE_QUERY_STATUS);//SERVICE_ALL_ACCESS);
//
////  if (ChangeServiceConfig(
////    SvcSCH, //   handle   of   service
////    SERVICE_NO_CHANGE, //SERVICE_NO_CHANGE,   //   service   type:   no   change
////    SERVICE_AUTO_START, //   change   service   start   type
////    SERVICE_NO_CHANGE, //   error   control:   no   change
////    nil, //   binary   path:   no   change
////    nil, //   load   order   group:   no   change
////    nil, //   tag   ID:   no   change
////    nil, //   dependencies:   no   change
////    nil, //   account   name:   no   change
////    nil, //   password:   no   change
////    nil)) then
////    showmessage('Auto Start OK')
////  else
////    showmessage('Auto Start Error');
////    if SvcSCH <= 0 then Exit;
//  try
//    Result := WinSVC.StartService(SvcSCH, 0, arg);
//    CloseServiceHandle(SvcSCH);
//    CloseServiceHandle(SCH);
//  except
//    CloseServiceHandle(SvcSCH);
//    CloseServiceHandle(SCH);
//    Exit;
//  end;
end;
//停止服务
function StopService(const SvrName: string): Boolean;
var
  SCH, SvcSCH: SC_HANDLE;
  SS: TServiceStatus;
begin
  Result := False;
  SCH := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SCH <= 0 then Exit;
  SvcSCH := OpenService(SCH, PChar(SvrName), SERVICE_ALL_ACCESS);
  if SvcSCH <= 0 then Exit;
  try
    Result := ControlService(SvcSCH, SERVICE_CONTROL_STOP, SS);
    CloseServiceHandle(SCH);
    CloseServiceHandle(SvcSCH);
  except
    CloseServiceHandle(SCH);
    CloseServiceHandle(SvcSCH);
    Exit;
  end;
end;

function ServiceIsRunning(sServiceName: string): boolean;
var
  hService, hSCManager: SC_HANDLE;
  SS: TServiceStatus;
begin
  hSCManager:= OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_CONNECT);
  if hSCManager = 0 then
  begin
    result := false;
    exit;
  end;
  hService := OpenService(hSCManager, PChar(sServiceName), SERVICE_QUERY_STATUS);
  if hService = 0 then
  begin
    CloseServiceHandle(hSCManager);
    result := false;
    exit;
  end;
  if not QueryServiceStatus(hService, SS) then
    result := false
  else
  begin
    case SS.dwCurrentState of
      SERVICE_CONTINUE_PENDING:
        result := true;
      SERVICE_PAUSE_PENDING:
        result := false;
      SERVICE_PAUSED:
        result := false;
      SERVICE_RUNNING:
        result := true;
      SERVICE_START_PENDING:
        result := true;
      SERVICE_STOP_PENDING:
        result := false;
      SERVICE_STOPPED:
        result := false;
    else
      result := false;
    end;
  end;
  CloseServiceHandle(hSCManager);
  CloseServiceHandle(hService);
end;
{ Memory }

procedure Get_MemoryTotalSize(var iPhysicsMemoryTotalSize,
  iVirtualMemoryTotalSize, iPageFileMemoryTotalSize: DWORD);
var
  msMemory: TMemoryStatus;
begin
  {
    iPhysicsMemoryTotalSize 物理内存总容量
    iVirtualMemoryTotalSize 虚拟内存总容量
    iPageFileMemoryTotalSize 交换内存（页面）总容量
  }
  msMemory.dwLength := SizeOf(msMemory);
  GlobalMemoryStatus(msMemory);
  iPhysicsMemoryTotalSize := msMemory.dwTotalPhys;
  iVirtualMemoryTotalSize := msMemory.dwTotalVirtual;
  iPageFileMemoryTotalSize := msMemory.dwTotalPageFile;
end;

procedure Get_MemoryCurrentSize(var iPhysicsMemoryCurrentSize,
  iVirtualMemoryCurrentSize, iPageFileMemoryCurrentSize: DWORD);
var
  msMemory: TMemoryStatus;
begin
  {
    iPhysicsMemoryCurrentSize 物理内存可用容量
    iVirtualMemoryCurrentSize 虚拟内存可用容量
    iPageFileMemoryCurrentSize 交换内存（页面）可用容量
  }
  msMemory.dwLength := SizeOf(msMemory);
  GlobalMemoryStatus(msMemory);
  iPhysicsMemoryCurrentSize := msMemory.dwAvailPhys;
  iVirtualMemoryCurrentSize := msMemory.dwAvailVirtual;
  iPageFileMemoryCurrentSize := msMemory.dwAvailPageFile;
end;

function Get_MemoryUsage: Double;
var
  msMemory: TMemoryStatus;
begin // 返回内存当前使用率 总的是100%，传回的是0-100%间的使用率，可以自己做转换。
  try
    msMemory.dwLength := SizeOf(msMemory);
    GlobalMemoryStatus(msMemory);
    result := msMemory.dwMemoryLoad;
  except
    result := 0;
  end;
end;

{ CPU.Private }

procedure CollectCPUData;
Var
  BS, I: Integer;
  _PCB_Instance: PPERF_COUNTER_BLOCK;
  _PID_Instance: PPERF_INSTANCE_DEFINITION;
  st: TFileTime;
  H: HKEY;
  R: DWORD;
  DwDataSize, DwType: DWORD;
begin
  if _IsWinNT then
  begin
    BS := _BufferSize;
    while RegQueryValueEx(HKEY_PERFORMANCE_DATA, Processor_IDX_Str, nil, nil,
      PBYTE(_PerfData), @BS) = ERROR_MORE_DATA do
    begin
      Inc(_BufferSize, $1000);
      BS := _BufferSize;
      ReallocMem(_PerfData, _BufferSize);
    end;

    _POT := PPERF_OBJECT_TYPE(DWORD(_PerfData) + _PerfData.HeaderLength);
    for I := 1 to _PerfData.NumObjectTypes do
    begin
      if _POT.ObjectNameTitleIndex = Processor_IDX then
        break;
      _POT := PPERF_OBJECT_TYPE(DWORD(_POT) + _POT.TotalByteLength);
    end;

    if _POT.ObjectNameTitleIndex <> Processor_IDX then
      raise Exception.Create(RES_CPU_NO_PROCESSOR);
    if _ProcessorsCount < 0 then
    begin
      _ProcessorsCount := _POT.NumInstances;
      GetMem(_Counters, _ProcessorsCount * SizeOf(TInt64));
      GetMem(_PrevCounters, _ProcessorsCount * SizeOf(TInt64));
    end;

    _PCD := PPERF_COUNTER_DEFINITION(DWORD(_POT) + _POT.HeaderLength);
    for I := 1 to _POT.NumCounters do
    begin
      if _PCD.CounterNameTitleIndex = CPUUsageIDX then
        break;
      _PCD := PPERF_COUNTER_DEFINITION(DWORD(_PCD) + _PCD.ByteLength);
    end;

    if _PCD.CounterNameTitleIndex <> CPUUsageIDX then
      Raise Exception.Create(RES_CPU_UNABLE_USAGE);
    _PID_Instance := PPERF_INSTANCE_DEFINITION
      (DWORD(_POT) + _POT.DefinitionLength);
    for I := 0 to _ProcessorsCount - 1 do
    begin
      _PCB_Instance := PPERF_COUNTER_BLOCK(DWORD(_PID_Instance) +
        _PID_Instance.ByteLength);
      _PrevCounters[I] := _Counters[I];
      _Counters[I] :=
        FInt64(PInt64(DWORD(_PCB_Instance) + _PCD.CounterOffset)^);
      _PID_Instance := PPERF_INSTANCE_DEFINITION(DWORD(_PCB_Instance) +
        _PCB_Instance.ByteLength);
    end;

    _PrevSysTime := _SysTime;
    SystemTimeToFileTime(_PerfData.SystemTime, st);
    _SysTime := FInt64(TInt64(st));
  end
  else
  begin
    if Not _W9xCollecting then
    begin
      R := RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StartStat', 0,
        KEY_ALL_ACCESS, H);
      if R <> ERROR_SUCCESS then
        Raise Exception.Create(RES_CPU_UNABLE_PERFORMANCE);
      DwDataSize := SizeOf(DWORD);
      RegQueryValueEx(H, 'KERNEL\CPUUsage', nil, @DwType, PBYTE(@_W9xCpuUsage),
        @DwDataSize);
      RegCloseKey(H);
      R := RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StatData', 0, KEY_READ,
        _W9xCpuKey);
      if R <> ERROR_SUCCESS then
        Raise Exception.Create(RES_CPU_NOREAD_PERFORMANCE);
      _W9xCollecting := True;
    end;

    DwDataSize := SizeOf(DWORD);
    RegQueryValueEx(_W9xCpuKey, 'KERNEL\CPUUsage', nil, @DwType,
      PBYTE(@_W9xCpuUsage), @DwDataSize);
  end;
end;

procedure ReleaseCPUData;
Var
  H: HKEY;
  R: DWORD;
  DwDataSize, DwType: DWORD;
begin
  if _IsWinNT then
    Exit;
  if Not _W9xCollecting then
    Exit;
  _W9xCollecting := false;
  RegCloseKey(_W9xCpuKey);
  R := RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StopStat', 0, KEY_ALL_ACCESS, H);
  if R <> ERROR_SUCCESS then
    Exit;
  DwDataSize := SizeOf(DWORD);
  RegQueryValueEx(H, 'KERNEL\CPUUsage', Nil, @DwType, PBYTE(@_W9xCpuUsage),
    @DwDataSize);
  RegCloseKey(H);
end;

function GetCPUVendor: TVendor; assembler; register;
asm
  PUSH EBX { Save affected register }
  PUSH EDI
  MOV EDI,EAX { @Result (TVendor) }
  MOV EAX,0
  DW $A20F { CPUID Command }
  MOV EAX,EBX
  XCHG EBX,ECX { save ECX result }
  MOV ECX,4
@1:
  STOSB
  SHR EAX,8
  LOOP @1
  MOV EAX,EDX
  MOV ECX,4
@2:
  STOSB
  SHR EAX,8
  LOOP @2
  MOV EAX,EBX
  MOV ECX,4
@3:
  STOSB
  SHR EAX,8
  LOOP @3
  POP EDI { Restore registers }
  POP EBX
end;

function GetCPUID: TCPUID; assembler; register;
asm      // Get CPU ID(4 ints)
  PUSH    EBX         { Save affected register }
  PUSH    EDI
  MOV     EDI,EAX     { @Resukt }
  MOV     EAX,1
  DW      $A20F       { CPUID Command }
  STOSD               { CPUID[1] }
  MOV     EAX,EBX
  STOSD               { CPUID[2] }
  MOV     EAX,ECX
  STOSD               { CPUID[3] }
  MOV     EAX,EDX
  STOSD               { CPUID[4] }
  POP     EDI         { Restore registers }
  POP     EBX
end;

{ CPU.public }

function Get_CPUUsage(Index: Integer): Double;
{
  获取CPU当前使用率
}
begin
  if _IsWinNT then
  begin
    if _ProcessorsCount < 0 then
      CollectCPUData;
    if (Index >= _ProcessorsCount) Or (Index < 0) then
      Raise Exception.Create(RES_CPU_INDEX_OUT);
    if _PrevSysTime = _SysTime then
      result := 0
    else
      result := 1 - (_Counters[index] - _PrevCounters[index]) /
        (_SysTime - _PrevSysTime);
  end
  else
  begin
    if Index <> 0 then
      Raise Exception.Create(RES_CPU_INDEX_OUT);
    if Not _W9xCollecting then
      CollectCPUData;
    result := _W9xCpuUsage / 100;
  end;
end;

function Get_CPUNo: string;
var // Get CPU NO using GetCPUID function and trun it to string
  No: TCPUID;
  S: string;
begin
  No := GetCPUID;
  S := '0000' + IntToHex(No[2]);
  result := IntToHex(No[1]) + '-' + Copy(S, length(S) - 4, 4) + '-' +
    IntToHex(No[3]) + '-' + IntToHex(No[4]);
end;

function Get_CPUVender: string;
begin // Get CPU vender using GetCPUVendor function and trun it to string
  result := string(GetCPUVendor);
end;

function Get_CPUCount: Integer;
{
  获取CPU数量
}
begin
  if _IsWinNT then
  begin
    if _ProcessorsCount < 0 then
      CollectCPUData;
    result := _ProcessorsCount;
  end
  else
  begin
    result := 1;
  end;
end;

function Get_CPUSpeed: Double;
const
  DelayTime = 500; // 时间单位是毫秒
var
  TimerHi, TimerLo: DWORD;
  PriorityClass, Priority: Integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);
  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
  Sleep(10);
  asm
    dw 310Fh // rdtsc
    mov TimerLo, eax
    mov TimerHi, edx
  end;
  Sleep(DelayTime);
  asm
    dw 310Fh // rdtsc
    sub eax, TimerLo
    sbb edx, TimerHi
    mov TimerLo, eax
    mov TimerHi, edx
  end;
  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);
  result := (TimerLo + TimerHi * 65536) / (1000.0 * DelayTime);
end;

{ Disk }

function Get_DiskInfo: string; // 获取硬盘信息
var
  Str: string;
  Drivers: Integer;
  driver: Char;
  I, temp: Integer;
  d1, d2, d3, d4: DWORD;
  ss: string;
begin
  ss := '';
  Drivers := GetLogicalDrives;
  temp := (1 and Drivers);
  for I := 0 to 26 do
  begin
    if temp = 1 then
    begin
      driver := Char(I + Integer('A'));
      Str := driver + ':';
      if (driver <> '') and (getdrivetype(PChar(Str)) <> drive_cdrom) and
        (getdrivetype(PChar(Str)) <> DRIVE_REMOVABLE) then
      begin
        GetDiskFreeSpace(PChar(Str), d1, d2, d3, d4);
        ss := ss + Str + Format('总空间: %f GB,',
          [d4 / 1024 / 1024 / 1024 * d2 * d1]) + Format('剩余空间: %f GB',
          [d3 / 1024 / 1024 / 1024 * d2 * d1]) + '; ';
      end;
    end;
    Drivers := (Drivers shr 1);
    temp := (1 and Drivers);
  end;
  result := ss;
end;

function Get_HDSerialNo: string;
begin
  result := Get_IdeHDSerialNo;
  if length(result) = 0 then
    result := Get_ScsiHDSerialNo;
end;

function Get_IdeHDSerialNo: string;
const
  IDENTIFY_BUFFER_SIZE = 512;
type
  TIDERegs = packed record
    bFeaturesReg: Byte; // Used for specifying SMART "commands".
    bSectorCountReg: Byte; // IDE sector count register
    bSectorNumberReg: Byte; // IDE sector number register
    bCylLowReg: Byte; // IDE low order cylinder value
    bCylHighReg: Byte; // IDE high order cylinder value
    bDriveHeadReg: Byte; // IDE drive/head register
    bCommandReg: Byte; // Actual IDE command.
    bReserved: Byte; // reserved for future use. Must be zero.
  end;

  TSendCmdInParams = packed record
    // Buffer size in bytes
    cBufferSize: DWORD;
    // Structure with drive register values.
    irDriveRegs: TIDERegs;
    // Physical drive number to send command to (0,1,2,3).
    bDriveNumber: Byte;
    bReserved: array [0 .. 2] of Byte;
    dwReserved: array [0 .. 3] of DWORD;
    bBuffer: array [0 .. 0] of Byte; // Input buffer.
  end;

  TIdSector = packed record
    wGenConfig: word;
    wNumCyls: word;
    wReserved: word;
    wNumHeads: word;
    wBytesPerTrack: word;
    wBytesPerSector: word;
    wSectorsPerTrack: word;
    wVendorUnique: array [0 .. 2] of word;
    sSerialNumber: array [0 .. 19] of AnsiChar;
    wBufferType: word;
    wBufferSize: word;
    wECCSize: word;
    sFirmwareRev: array [0 .. 7] of Char;
    sModelNumber: array [0 .. 39] of Char;
    wMoreVendorUnique: word;
    wDoubleWordIO: word;
    wCapabilities: word;
    wReserved1: word;
    wPIOTiming: word;
    wDMATiming: word;
    wBS: word;
    wNumCurrentCyls: word;
    wNumCurrentHeads: word;
    wNumCurrentSectorsPerTrack: word;
    ulCurrentSectorCapacity: DWORD;
    wMultSectorStuff: word;
    ulTotalAddressableSectors: DWORD;
    wSingleWordDMA: word;
    wMultiWordDMA: word;
    bReserved: array [0 .. 127] of Byte;
  end;

  PIdSector = ^TIdSector;

  TDriverStatus = packed record
    // 驱动器返回的错误代码，无错则返回0
    bDriverError: Byte;
    // IDE出错寄存器的内容，只有当bDriverError 为 SMART_IDE_ERROR 时有效
    bIDEStatus: Byte;
    bReserved: array [0 .. 1] of Byte;
    dwReserved: array [0 .. 1] of DWORD;
  end;

  TSendCmdOutParams = packed record
    // bBuffer的大小
    cBufferSize: DWORD;
    // 驱动器状态
    DriverStatus: TDriverStatus;
    // 用于保存从驱动器读出的数据的缓冲区，实际长度由cBufferSize决定
    bBuffer: array [0 .. 0] of Byte;
  end;
var
  hDevice: THandle;
  cbBytesReturned: DWORD;
  // ptr : PChar;
  SCIP: TSendCmdInParams;
  aIdOutCmd: array [0 .. (SizeOf(TSendCmdOutParams) + IDENTIFY_BUFFER_SIZE - 1)
    - 1] of Byte;
  IdOutCmd: TSendCmdOutParams absolute aIdOutCmd;

  procedure ChangeByteOrder(var Data; Size: Integer);
  var
    ptr: PChar;
    I: Integer;
    c: Char;
  begin
    ptr := @Data;
    for I := 0 to (Size shr 1) - 1 do
    begin
      c := ptr^;
      ptr^ := (ptr + 1)^;
      (ptr + 1)^ := c;
      Inc(ptr, 2);
    end;
  end;

begin
  result := ''; // 如果出错则返回空串
  if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
  begin // Windows NT, Windows 2000
    // 提示：改变名称可适用于其它驱动器，如第二个驱动器： '\\.\PhysicalDrive1\'
    hDevice := CreateFile('\\.\PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  end
  else // Version Windows 95 OSR2, Windows 98
    hDevice := CreateFile('\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0);
  if hDevice = INVALID_HANDLE_VALUE then
    Exit;
  try
    FillChar(SCIP, SizeOf(TSendCmdInParams) - 1, #0);
    FillChar(aIdOutCmd, SizeOf(aIdOutCmd), #0);
    cbBytesReturned := 0;
    // Set up data structures for IDENTIFY command.
    with SCIP do
    begin
      cBufferSize := IDENTIFY_BUFFER_SIZE;
      // bDriveNumber := 0;
      with irDriveRegs do
      begin
        bSectorCountReg := 1;
        bSectorNumberReg := 1;
        // if Win32Platform=VER_PLATFORM_WIN32_NT then bDriveHeadReg := $A0
        // else bDriveHeadReg := $A0 or ((bDriveNum and 1) shl 4);
        bDriveHeadReg := $A0;
        bCommandReg := $EC;
      end;
    end;
    if not DeviceIoControl(hDevice, $0007C088, @SCIP, SizeOf(TSendCmdInParams) -
      1, @aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil) then
      Exit;
  finally
    CloseHandle(hDevice);
  end;
  with PIdSector(@IdOutCmd.bBuffer)^ do
  begin
    ChangeByteOrder(sSerialNumber, SizeOf(sSerialNumber));
    (PChar(@sSerialNumber) + SizeOf(sSerialNumber))^ := #0;
    result := trim(StrPas(sSerialNumber));
  end;
end;

function Get_ScsiHDSerialNo: string;
type
  TScsiPassThrough = record
    length: word;
    ScsiStatus: Byte;
    PathId: Byte;
    TargetId: Byte;
    Lun: Byte;
    CdbLength: Byte;
    SenseInfoLength: Byte;
    DataIn: Byte;
    DataTransferLength: ULONG;
    TimeOutValue: ULONG;
    DataBufferOffset: DWORD;
    SenseInfoOffset: ULONG;
    Cdb: array [0 .. 15] of Byte;
  end;

  TScsiPassThroughWithBuffers = record
    spt: TScsiPassThrough;
    bSenseBuf: array [0 .. 31] of Byte;
    bDataBuf: array [0 .. 191] of Byte;
  end;
var
  dwReturned: DWORD;
  len: DWORD;
  sDeviceName: string;
  hDevice: THandle;
  Buffer: array [0 .. SizeOf(TScsiPassThroughWithBuffers) +
    SizeOf(TScsiPassThrough) - 1] of Byte;
  sptwb: TScsiPassThroughWithBuffers absolute Buffer;
begin
  result := '';
  sDeviceName := 'C:';
  hDevice := CreateFile(PChar('\\.\' + sDeviceName), GENERIC_READ or
    GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
    OPEN_EXISTING, 0, 0);
  if hDevice = INVALID_HANDLE_VALUE then
    Exit;
  try
    FillChar(Buffer, SizeOf(Buffer), #0);
    with sptwb.spt do
    begin
      length := SizeOf(TScsiPassThrough);
      CdbLength := 6; // CDB6GENERIC_LENGTH
      SenseInfoLength := 24;
      DataIn := 1; // SCSI_IOCTL_DATA_IN
      DataTransferLength := 192;
      TimeOutValue := 2;
      DataBufferOffset := PChar(@sptwb.bDataBuf) - PChar(@sptwb);
      SenseInfoOffset := PChar(@sptwb.bSenseBuf) - PChar(@sptwb);
      Cdb[0] := $12; // OperationCode := SCSIOP_INQUIRY;
      Cdb[1] := $01; // Flags := CDB_INQUIRY_EVPD; Vital product data
      Cdb[2] := $80; // PageCode            Unit serial number
      Cdb[4] := 192; // AllocationLength
    end;
    len := sptwb.spt.DataBufferOffset + sptwb.spt.DataTransferLength;
    if DeviceIoControl(hDevice, $0004D004, @sptwb, SizeOf(TScsiPassThrough),
      @sptwb, len, dwReturned, nil) and
      ((PChar(@sptwb.bDataBuf) + 1)^ = #$80) then
      SetString(result, PChar(@sptwb.bDataBuf) + 4,
        Ord((PChar(@sptwb.bDataBuf) + 3)^));
    result := trim(result);
  finally
    CloseHandle(hDevice);
  end;
end;

function Get_DiskSerialNo(DriveID: Char): string;
var // Get Disk Serial NO by disk ID(C,D,E...)
  VolumeSerialNumber: DWORD;
  MaximumComponentLength: Cardinal;
  FileSystemFlags: Cardinal;
begin
  result := '';
  GetVolumeInformation(PChar(DriveID + ':\'), nil, 0, @VolumeSerialNumber,
    MaximumComponentLength, FileSystemFlags, nil, 0);
  result := IntToHex(HiWord(VolumeSerialNumber), 4) + '-' +
    IntToHex(LoWord(VolumeSerialNumber), 4);
end;

{ Net }

function Get_NetMACNo1: string;
var // Get a NetMAC
  Lib: Cardinal;
  Func: function(GUID: PGUID): Longint; stdcall;
  GUID1, GUID2: TGUID;
begin
  result := '';
  Lib := LoadLibrary('rpcrt4.dll');
  if Lib <> 0 then
    try
      if Win32Platform <> VER_PLATFORM_WIN32_NT then
        @Func := GetProcAddress(Lib, 'UuidCreate')
      else
        @Func := GetProcAddress(Lib, 'UuidCreateSequential');
      if Assigned(Func) then
      begin
        if (Func(@GUID1) = 0) and (Func(@GUID2) = 0) and
          (GUID1.d4[2] = GUID2.d4[2]) and (GUID1.d4[3] = GUID2.d4[3]) and
          (GUID1.d4[4] = GUID2.d4[4]) and (GUID1.d4[5] = GUID2.d4[5]) and
          (GUID1.d4[6] = GUID2.d4[6]) and (GUID1.d4[7] = GUID2.d4[7]) then
        begin
          result := IntToHex(GUID1.d4[2], 2) + IntToHex(GUID1.d4[3], 2) +
            IntToHex(GUID1.d4[4], 2) + IntToHex(GUID1.d4[5], 2) +
            IntToHex(GUID1.d4[6], 2) + IntToHex(GUID1.d4[7], 2);
        end;
      end;
    finally
      FreeLibrary(Lib);
    end;
end;

function Get_NetMACNo2: string;
var
  ncb: TNCB;
  S: string;
  adapt: TASTAT;
  lanaEnum: TLanaEnum;
  I, J: Integer;
  strPart, strMAC: string;
begin
  FillChar(ncb, SizeOf(TNCB), 0);
  ncb.ncb_command := Char(NCBEnum);
  ncb.ncb_buffer := PAnsiChar(@lanaEnum);
  ncb.ncb_length := SizeOf(TLanaEnum);
  S := Netbios(@ncb);
  for I := 0 to Integer(lanaEnum.length) - 1 do
  begin
    FillChar(ncb, SizeOf(TNCB), 0);
    ncb.ncb_command := Char(NCBReset);
    ncb.ncb_lana_num := lanaEnum.lana[I];
    Netbios(@ncb);
    Netbios(@ncb);
    FillChar(ncb, SizeOf(TNCB), 0);
    ncb.ncb_command := Chr(NCBAstat);
    ncb.ncb_lana_num := lanaEnum.lana[I];
    ncb.ncb_callname := '*               ';
    ncb.ncb_buffer := PAnsiChar(@adapt);
    ncb.ncb_length := SizeOf(TASTAT);
    strMAC := '';
    if Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      (* ' Windows NT, Windows 2000 ' *)
      if Netbios(@ncb) = Chr(0) then
        strMAC := '';
      for J := 0 to 5 do
      begin
        strPart := IntToHex(Integer(adapt.adapter.adapter_address[J]), 2);
        strMAC := strMAC + strPart;
      end;
      (* ' Windows 95 OSR2, Windows 98 ' *)
    end
    else if Netbios(@ncb) <> Chr(0) then
    begin
      for J := 0 to 5 do
      begin
        strPart := IntToHex(Integer(adapt.adapter.adapter_address[J]), 2);
        strMAC := strMAC + strPart;
      end;
    end;
  end;
  result := strMAC;
end;

function Get_NetMACNo3: string;
type // Get MAK of net card
  TTransportInfo = record
    quality_of_service: DWORD;
    number_of_vcs: DWORD;
    transport_name: PWChar;
    transport_address: PWChar;
    wan_ish: Boolean;
  end;

  PTransportInfo = ^TTransportInfo;

var
  E, ResumeHandle, EntriesRead, TotalEntries: Cardinal;
  I: Integer;
  pszServer: array [0 .. 128] of WideChar;
  pBuffer: pointer;
  pInfo: PTransportInfo;
begin
  result := '000000000000';
  pBuffer := nil;
  ResumeHandle := 0;
  E := NetWkstaTransportEnum(StringToWideChar('', pszServer, 129), 0, pBuffer,
    -1, EntriesRead, TotalEntries, ResumeHandle);
  if E = 0 then
  begin
    pInfo := pBuffer;
    for I := 1 to EntriesRead do
    begin
      if Pos('TCPIP', UpperCase(pInfo^.transport_name)) <> 0 then
        result := String(pInfo^.transport_address);
      Inc(pInfo);
    end;
  end;
  if pBuffer <> nil then
    NetApiBufferFree(pBuffer);
end;

const
  MAX_ADAPTER_DESCRIPTION_LENGTH = 128;
  MAX_ADAPTER_NAME_LENGTH = 256;
  MAX_ADAPTER_ADDRESS_LENGTH = 8;
  DEFAULT_MINIMUM_ENTITIES = 32;
  MAX_HOSTNAME_LEN = 128;
  MAX_DOMAIN_NAME_LEN = 128;
  MAX_SCOPE_ID_LEN = 256;

  ERROR_NO_DATA: Longint = 232;
  ERROR_NOT_SUPPORTED: Longint = 50;
  ERROR_INVALID_PARAMETER: Longint = 87;
  ERROR_BUFFER_OVERFLOW: Longint = 111;

type
  time_t = Integer;

  IP_ADDRESS_STRING = packed record
    Addr: array [0 .. 15] of AnsiChar;
  end;

  PIP_ADDRESS_STRING = ^IP_ADDRESS_STRING;
  IP_MASK_STRING = IP_ADDRESS_STRING;
  PIP_MASK_STRING = ^IP_MASK_STRING;
  PIPAdapterInfo = ^TIPAdapterInfo;

  TIPAdapterInfo = packed record
    Next: PIPAdapterInfo; // 下一个节点的指针
    ComboIndex: DWORD;
    AdapterName: array [0 .. MAX_ADAPTER_NAME_LENGTH + 3] of AnsiChar; // 适配器名称
    Description: array [0 .. MAX_ADAPTER_DESCRIPTION_LENGTH + 3] of AnsiChar;
    // 适配器描述信息
    AddressLength: UINT; // Address域的最大长度,传递MAX_ADAPTER_ADDRESS_LENGTH常量即可
    Address: array [0 .. MAX_ADAPTER_ADDRESS_LENGTH - 1] of Byte; // 适配器物理地址
    Index: DWORD; // 适配器序号
    uType: UINT; // 适配器类型
    { MIB_IF_TYPE_OTHER: Other
      MIB_IF_TYPE_ETHERNET: Ethernet
      MIB_IF_TYPE_TOKENRING: Tokenring
      MIB_IF_TYPE_FDDI: FDDI
      MIB_IF_TYPE_PPP: PPP
      MIB_IF_TYPE_LOOPBACK: LoopBack
      MIB_IF_TYPE_SLIP: Slip
      Unknow }
    DhcpEnabled: UINT; // 是否使用了DHCP服务器
    CurrentIpAddress: PIP_ADDRESS_STRING; // DHCP服务器IP
    IpAddressList: IP_ADDRESS_STRING; // 子网掩码
    GatewayList: IP_ADDRESS_STRING; // 默认网关
    DhcpServer: IP_ADDRESS_STRING; // DHCP服务器IP
    HaveWins: Bool; // 是否启用wins服务器
    PrimaryWinsServer: IP_ADDRESS_STRING; // wins服务器主IP
    SecondaryWinsServer: IP_ADDRESS_STRING; // wins服务器副IP
    LeaseObtained: time_t; // 当前DHCP租用时间
    LeaseExpires: time_t; // 当前DHCP租用期满时间
  end;

function GetAdaptersInfo(Buf: PIPAdapterInfo; var BufLen: ULONG): DWORD;
  stdcall; external 'iphlpapi.dll' name 'GetAdaptersInfo';

function Get_NetInfo: PIPAdapterInfo;
var
  Info: PIPAdapterInfo;
  BufLen: ULONG;
begin
  New(Info);
  BufLen := SizeOf(Info);
  if GetAdaptersInfo(Info, BufLen) = ERROR_BUFFER_OVERFLOW then
  begin
    Dispose(Info);
    GetMem(Info, BufLen);
    GetAdaptersInfo(Info, BufLen)
  end;
  result := Info;
end;

function Get_NetMACNo4: string;
var
  Info: PIPAdapterInfo;
  I: Integer;
begin
  Info := Get_NetInfo;
  result := '';
  while Assigned(Info) do
  begin
    result := result + #13#10;
    for I := 0 to Info.AddressLength - 1 do
      result := result + IntToHex(Info.Address[I], 2);
    Info := Info.Next;
  end;
  if result <> '' then
    Delete(result, 1, 2);
  Dispose(Info);
end;

function Get_NetMACNo(MethodId: Integer): string;
begin
  case MethodId of
    0:
      result := Get_NetMACNo1;
    1:
      result := Get_NetMACNo2;
    2:
      result := Get_NetMACNo3;
    3:
      result := Get_NetMACNo4;
  end;
end;

function Get_NetNames: string;
var
  Info: PIPAdapterInfo;
begin
  Info := Get_NetInfo;
  result := '';
  while Assigned(Info) do
  begin
    result := result + #13#10 + Info.AdapterName;
    Info := Info.Next;
  end;
  if result <> '' then
    Delete(result, 1, 2);
  Dispose(Info);
end;

function Get_NetDescription: string;
var
  Info: PIPAdapterInfo;
begin
  Info := Get_NetInfo;
  result := '';
  while Assigned(Info) do
  begin
    result := result + #13#10 + Info.Description;
    Info := Info.Next;
  end;
  if result <> '' then
    Delete(result, 1, 2);
  Dispose(Info);
end;

function CheckInternet: Boolean;
begin
  result := InternetCheckConnection('http://www.net.cn/', 1, 0);
end;

var
  myPing: Tping;

function Ping(ip: string): Boolean;
begin
  if not Assigned(myPing) then myPing:= Tping.create;
  myPing.pinghost(IP, Result);
end;

function GetLocalIP: string;
type
  TaPInAddr = array [0..10] of PInAddr;   //用于存储活动的ip地址列表
  PaPInAddr = ^TaPInAddr;
var
  phe : PHostEnt;
  pptr : PaPInAddr;
  Buff : array [0..63] of Ansichar;   //store hostname
  I : Integer;
  GInitData : TWSADATA;
  wVersion: word;
begin
  wVersion:= MAKEWORD(1,1);         //winsock dll version
  Result :='';
  if WSAStartup(wVersion, GInitData) = 0 then     //初始化windows socket
  begin
  //function gethostname(name: MarshaledAString; len: Integer): Integer; stdcall;
    if GetHostName(Buff, SizeOf(Buff)) = 0 then //计算机名称
        phe := GetHostByName(Buff);
    if phe = nil then
       Exit;
    pptr := PaPInAddr(Phe^.h_addr_list);
    I := 0;
    while pptr^[I] <> nil do begin
      result:= StrPas(inet_ntoa(pptr^[I]^));
      Inc(I);
    end;
    WSACleanup;           //关闭、清理windows socket
  end;
end;

{ Display }

function Get_DisplayFrequency: Integer;
var
  DeviceMode: TDeviceMode;
  // 这个函数返回的显示刷新率是以Hz为单位的
begin
  EnumDisplaySettings(nil, Cardinal(-1), DeviceMode);
  result := DeviceMode.dmDisplayFrequency;
end;

type
  IEnumVariant = interface(IUnknown)
    ['{00020404-0000-0000-C000-000000000046}']
    function Next(celt: Longword; var rgvar: OleVariant; pceltFetched: Cardinal)
      : HResult; stdcall;
    function Skip(celt: Longword): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumVariant): HResult; stdcall;
  end;

function Get_DisplayInfo: string;
var
  wmi, objs, obj: OleVariant;
  Enum: IEnumVariant;
  Value: Cardinal;
begin
  wmi := CreateOleObject('WbemScripting.SWbemLocator');
  // ConnectServer无参表示连接本机
  objs := wmi.ConnectServer().ExecQuery('SELECT * FROM Win32_VideoController');
  Enum := IUnknown(objs._NewEnum) as IEnumVariant;
  Enum.Reset;
  // 扫描每一块显卡
  result := '';
  while Enum.Next(1, obj, Value) = 0 do
  begin
    result := result + '名称:' + obj.Name + ' 制造商:' + obj.AdapterCompatibility +
      ' 芯片类型:' + obj.VideoProcessor + ' DAC类型:' + obj.AdapterDACType + ' 显存:' +
      VarToStr(obj.AdapterRAM div 1024 div 1024) + 'M' + ' 颜色:' +
      VarToStr(obj.CurrentBitsPerPixel) + '位 ';
  end;
end;

{ Info 信息处理部分 }

procedure WriteInfo(Info: string); // 最后处理留下的信息
begin
  FInfoList.Insert(0, Info);
end;

procedure ClearInfo; // 最后处理留下的信息
begin
  FInfoList.Clear;
end;

function LastInfo: string; // 最后处理留下的信息
begin
  if FInfoList.Count > 0 then
    result := FInfoList[0]
  else
    result := '';
  FInfoList.Clear;
end;

function GetInfoList: TStrings; // 最后处理留下的信息
begin
  result := FInfoList;
end;

{ Dialog 对话框部分 }

function DlgConnectionString(SConnectionString: string): string;
begin
  Result := '';
  with TConnEditForm.Create(Application) do
  try
    Caption := '数据库链接';
//    PropInfo := GetPropInfo(Component.ClassInfo, SConnectionString);    //利用反射得到空间ConnectionString属性内容
//    InitialConnStr := GetStrProp(Component, PropInfo);
    Result := Edit(SConnectionString);
  finally
    Free;
  end;
end;

procedure DlgInfo(ACaption, Infomation: string; TimeCount: Integer);
begin
  DlgInfo(ACaption, Infomation, [mbOK], TimeCount);
end;

function DlgInfo(ACaption, Infomation: string; Buttons: TMsgDlgButtons;
  TimeCount: Integer): Integer;
var
  Form: TForm;
  Prompt: TLabel;
  tmpValue, MaxLength, MaxHeight, btnLeft: Integer;
  I: Integer;
  ATimer: TTimer;
  ATimeEventClass: TimeEventClass;
  ALines: TStringList;

  procedure CreateBtn(ACaption, AName: string; Abtn: TBitBtnKind; AResult: TModalResult;
    IsDefaule: Boolean = false);
  begin
    with TBitBtn.Create(Form) do
    begin
      Parent := Form;
      Caption := ACaption;
      Name := AName;
      Kind := Abtn;
      Default := IsDefaule;
      ModalResult:= AResult;
      SetBounds(btnLeft - 78, Prompt.Top + Prompt.Height + 20, 78, 25);
      Dec(btnLeft, 80);
    end;
  end;

begin
  ALines := TStringList.Create;
  ALines.Text := Infomation;
  // Put string into stringlist to get lines and max line
  Form := TForm.Create(Application);
  result := mrCancel;
  with Form do
    try
      (* Get max length and max width of lines *)
      MaxLength := 0;
      MaxHeight := 0;
      for I := 0 to ALines.Count - 1 do
      begin
        tmpValue := Canvas.TextWidth(ALines[I]);
        if tmpValue > MaxLength then
          MaxLength := tmpValue;
        tmpValue := Canvas.TextHeight(ALines[I]);
        if tmpValue > MaxHeight then
          MaxHeight := tmpValue;
      end;
      (* Set form options *)
      Canvas.Font := Font;
      BorderStyle := bsDialog;
      Caption := ACaption;
      ClientWidth := Max(180, MaxLength + 40);
      ClientHeight := Max(20, MaxHeight * ALines.Count + 70);
      Position := poScreenCenter;
      (* Display prompt *)
      Prompt := TLabel.Create(Form);
      with Prompt do
      begin
        Parent := Form;
        Caption := Infomation;
        Left := 20;
        Top := 10;
        AutoSize := True;
        WordWrap := True;
      end;
      (* Display button
        bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll);
        mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp *)
      btnLeft := Form.ClientWidth - 4;
      if mbHelp in Buttons then
        CreateBtn('帮助', 'bkHelp', bkHelp, mrNone);
      if mbAbort in Buttons then
        CreateBtn('退出', 'bkAbort', bkAbort, mrAbort);
      if mbCancel in Buttons then
        CreateBtn('放弃', 'bkCancel', bkCancel, mrCancel, True);
      if mbIgnore in Buttons then
        CreateBtn('跳过', 'bkIgnore', bkIgnore, mrIgnore);
      if mbNoToAll in Buttons then
        CreateBtn('所有错误', 'bkNo', bkNo, mrNo);
      if mbNo in Buttons then
        CreateBtn('错误', 'bkNo', bkNo, mrNo, True);
      if mbRetry in Buttons then
        CreateBtn('继续', 'bkRetry', bkRetry, mrRetry);
      if mbYesToAll in Buttons then
        CreateBtn('所有正确', 'bkAll', bkAll, mrAll);
      if mbYes in Buttons then
        CreateBtn('正确', 'bkYes', bkYes, mrYes);
      if mbAll in Buttons then
        CreateBtn('所有', 'bkAll', bkAll, mrAll);
      if mbOK in Buttons then
        CreateBtn('确定', 'bkOK', bkOK, mrOk);
      if mbNoToAll in Buttons then
        CreateBtn('全部放弃', 'bkOK', bkAll, mrNoToAll);
      if mbYesToAll in Buttons then
        CreateBtn('确定', 'bkOK', bkAll, mrYesToAll);
      if mbClose in Buttons then
        CreateBtn('确定', 'bkOK', bkClose, mrClose);;
      (* Timer *)
      if TimeCount > 0 then
      begin
        ATimer := TTimer.Create(Form);
        ATimeEventClass := TimeEventClass.Create(Form, TimeCount);
        with ATimer do
        begin
          InterVal := 1000;
          OnTimer := ATimeEventClass.TimeEvent;
        end;
        Form.OnClose := ATimeEventClass.EventFormClose;
      end;
      result := 0;
      FormStyle:= fsStayOnTop;
      if Assigned(FOnSay) then
        FOnSay(Infomation);
      if Buttons = [] then
        Show
      else begin
        result := ShowModal;
        Free;
      end;
    finally
      ALines.Free;
    end;
end;

function DlgInfo(ACaption: string; Values: TStrings; Index: Integer): Integer;
var
  Form: TForm;
  lst: TListBox;
  tmpValue, btnLeft: Integer;

  procedure CreateBtn(ACaption, AName: string; Abtn: TBitBtnKind;
    IsDefaule: Boolean = false);
  begin
    with TBitBtn.Create(Form) do
    begin
      Parent := Form;
      Caption := ACaption;
      Name := AName;
      Kind := Abtn;
      Default := IsDefaule;
      SetBounds(btnLeft - 78, lst.Top + lst.Height + 20, 78, 25);
      Dec(btnLeft, 80);
    end;
  end;

begin
  // Put string into stringlist to get lines and max line
  Form := TForm.Create(Application);
  result := mrCancel;
  with Form do try
    (* Get max length and max width of lines *)
    (* Set form options *)
    Canvas.Font := Font;
    BorderStyle := bsDialog;
    Caption := ACaption;
    ClientWidth := 200;
    ClientHeight := Min(278, Values.Count * 18 + 98);
    Position := poScreenCenter;
    (* Display prompt *)
    lst:= TListBox.Create(Form);
    with lst do
    begin
      Parent := Form;
      Left := 10;
      Top := 10;
      Width := Form.Width - 20;
      Height := Form.Height - 98;
      Items.Assign(Values);
      ItemIndex:= Index;
    end;
    (* Display button
      bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll);
      mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp *)
    btnLeft := Form.ClientWidth - 4;
    CreateBtn('放弃', 'bkCancel', bkCancel, True);
    CreateBtn('确定', 'bkOK', bkOK);
    result := 0;
    if ShowModal = mrOK then
      result := lst.ItemIndex
    else result := -1;
  finally
    Free;
  end;
end;

function DlgBusy(ACaption, GifFilename: string): TForm;
var
  Img: TImage;
  lbTitle: TLabel;
begin
  result := TForm.Create(Application);
  result.HandleNeeded;
  lbTitle := TLabel.Create(result);
  lbTitle.ParentColor := false;
  lbTitle.Transparent := false;
  lbTitle.Color := $00DE6412;
  lbTitle.Font.Color := $00400080;
  lbTitle.Parent := result;
  lbTitle.Caption := ACaption;
  Img := TImage.Create(result);
  Img.Parent := result;
  Img.AutoSize := True;
  with result do
  begin
    if GifFilename = '' then
      GifFilename := ExtractFilePath(Application.ExeName) +
        'Styles\Default\Busy.GIF';
    Img.Picture.LoadFromFile(GifFilename);
    result.Width := Img.Picture.Width;
    Img.Align := alTop;
    lbTitle.Align := alTop;
    Position := poScreenCenter;
    BorderStyle := bsNone;
    FormStyle := fsStayOnTop;
    DoubleBuffered := True;
    Show;
    lbTitle.WordWrap := True;
    lbTitle.AutoSize := True;
    result.Height := Img.Picture.Height + lbTitle.Height;
    // AnimationSpeed 设定动画速度，值越大，速度越快；
    // TGIFImage(Img.Picture.Graphic).AnimationSpeed := 200;
    TGIFImage(Img.Picture.Graphic).Animate := True;
    TGIFImage(Img.Picture.Graphic).ResumeDraw;
    if Perform(Cardinal(ACM_PLAY), WPARAM(-1), LPARAM(MakeLong(0, 500))) <> 1 then
      Repaint;
  end;
end;

type
  TDlgMultiInput = class
  private
    FForm: TForm;
    FSetting: TStrings;
    btn1, btn2: TBitBtn;
    procedure ValueListEditor1GetPickList(Sender: TObject; const KeyName: string; Values: TStrings);
    function GetValues: TStrings;
    procedure SetValues(const Value: TStrings);
    function GetCaption: string;
    procedure SetCaption(const Value: string);
  public
    vList: TValueListEditor;
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
    function ShowModal: Integer;
    property Caption: string read GetCaption write SetCaption;
    property Values: TStrings read GetValues write SetValues;
  end;

{ TDlgMultiInput }

constructor TDlgMultiInput.Create(AOwner: TComponent);
begin
  FForm:= TForm.Create(AOwner);
  FForm.HandleNeeded;
  FForm.Position := poScreenCenter;
  FForm.BorderStyle := bsDialog;
  FForm.FormStyle := fsStayOnTop;
  vList:= TValueListEditor.Create(nil);
  vList.Parent:= FForm;
  vList.Align:= alTop;
  vList.OnGetPickList:= ValueListEditor1GetPickList;
  FForm.Width:= 250;
  btn1:= TBitBtn.Create(nil);
  btn1.Parent:= FForm;
  btn1.Kind:= bkOK;
  btn1.Left:= 24;
  btn2:= TBitBtn.Create(nil);
  btn2.Parent:= FForm;
  btn2.Kind:= bkCancel;
  btn2.Left:= 136;
end;

destructor TDlgMultiInput.Destroy;
begin
  btn2.Free;
  btn1.Free;
  vList.Free;
  FForm.Free;
  inherited;
end;

function TDlgMultiInput.GetCaption: string;
begin
  Result:= FForm.Caption;
end;

function TDlgMultiInput.GetValues: TStrings;
begin
  Result:= vList.Strings;
end;

procedure TDlgMultiInput.SetCaption(const Value: string);
begin
  FForm.Caption:= Value;
end;

procedure TDlgMultiInput.SetValues(const Value: TStrings);
var
  I: Integer;
begin
  FSetting:= Value;
  vList.Strings.Clear;
  for I := 0 to FSetting.Count - 1 do
    vList.InsertRow(FSetting.Names[I], '', True);
  FForm.Height:= Min(vList.RowCount, 16) * 18 + 100;
  vList.Height:= FForm.Height - 68;
  btn1.Top:= FForm.Height - 64;
  btn2.Top:= FForm.Height - 64;
end;

function TDlgMultiInput.ShowModal: Integer;
begin
  FForm.DoubleBuffered := False;
  Result:= FForm.ShowModal;
end;

procedure TDlgMultiInput.ValueListEditor1GetPickList(Sender: TObject;
  const KeyName: string; Values: TStrings);
begin
  if FSetting.Values[KeyName] = '' then Values.Text:= ''
  else begin
  Values.Delimiter:= ',';
  Values.DelimitedText:= FSetting.Values[KeyName];
  end;
end;

function DlgMultiInput(Title, NameTitle, ValueTitle: string; Settings: TStrings): Boolean;
begin
  with TDlgMultiInput.Create(Application) do try
    Caption:= Title;
    vList.TitleCaptions.Text:= NameTitle + #13#10 + ValueTitle;
    Values:= Settings;
    Result:= ShowModal = mrOK;
    if Result then
      Settings.Assign(Values);
  finally
    Free;
  end;
end;

function ExcuteWait(FileName, Params: string): THandle;
var
  ShExecInfo: SHELLEXECUTEINFO;
begin
  FillChar(ShExecInfo, SizeOf(SHELLEXECUTEINFO), #0);
  ShExecInfo.cbSize := SizeOf(SHELLEXECUTEINFO);
  ShExecInfo.fMask := SEE_MASK_NOCLOSEPROCESS;
  ShExecInfo.Wnd := 0;
  ShExecInfo.lpVerb := nil;
  ShExecInfo.lpFile := PChar(FileName);
  ShExecInfo.lpParameters := PChar(Params);
  ShExecInfo.lpDirectory := ''; // PChar(Filename);
  ShExecInfo.nShow := SW_SHOW;
  ShExecInfo.hInstApp := 0;
  ShellExecuteEx(@ShExecInfo);
  WaitForSingleObject(ShExecInfo.hProcess, INFINITE);
end;

function RunWait(FileName: string; Visibility: Integer): THandle;
var
  zAppName: array [0 .. 512] of Char;
  zCurDir: array [0 .. 255] of Char;
  WorkDir: string;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  szValue: Cardinal;
begin
  try
    StrPCopy(zAppName, FileName);
    GetDir(0, WorkDir);
    StrPCopy(zCurDir, WorkDir);
    FillChar(StartupInfo, SizeOf(StartupInfo), #0);
    StartupInfo.cb := SizeOf(StartupInfo);
    StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
    StartupInfo.wShowWindow := Visibility;
    if not CreateProcess(nil, zAppName, nil, nil, false, Create_NEW_CONSOLE or
      NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
    begin
      result := 0;
      Exit;
    end
    else
    begin
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
      GetExitCodeProcess(ProcessInfo.hProcess, szValue);
      result:= szValue;
    end;
  finally
  end;
end;

{ Version 版本管理 }

//procedure SplitVer(Ver: string; var arrVer: TVonVersion);
//var
//  Idx: Cardinal;
//  P: PChar;
//  szS: string;
//begin
//  P := PChar(Ver);
//  szS := '';
//  Idx := 3;
//  repeat
//    case P[0] of
//      '.':
//        begin
//          if szS = '*' then
//            arrVer.arr[Idx] := 65535
//          else
//            arrVer.arr[Idx] := StrToInt(szS);
//          szS := '';
//          Dec(Idx);
//        end;
//    else
//      szS := szS + P[0];
//    end;
//    Inc(P);
//  until P[0] = #0;
//  if szS = '*' then
//    arrVer.arr[Idx] := 65535
//  else
//    arrVer.arr[Idx] := StrToInt(szS);
//end;
//
//function IncVer(Ver: TVonVersion): TVonVersion;
//begin
//  Result.Int:= Ver.Int + 1;
//end;
//
//function VerToStr(Version: TVonVersion): string;
//begin
//  result := IntToStr(Version.arr[3]) + '.' + IntToStr(Version.arr[2]) + '.' +
//    IntToStr(Version.arr[1]) + '.' + IntToStr(Version.arr[0]);
//end;
//
//function IncVer(Ver: string): string;
//var
//  PV1: TVonVersion;
//begin
//  SplitVer(Ver, PV1);
//  Result:= VerToStr(IncVer(PV1));
//end;
//
//procedure CopyVer(OrgVer: TVonVersion; var DestVer: TVonVersion);
//begin
//  Move(OrgVer.bytes[0], DestVer.bytes[0], 8);
//end;
//
//function VerToHex(Version: TVonVersion): string;
//begin
//  result := IntToHex(Version.arr[3], 4) + '.' + IntToHex(Version.arr[2], 4) + '.' +
//    IntToHex(Version.arr[1], 4) + '.' + IntToHex(Version.arr[0], 4);
//end;
//
//function CheckVer(SrcVer, DestVer: string): Integer;
//var
//  szSrcVer, szDestVer: TVonVersion;
//begin // 如果两个版本一样则返回0，如果原版本SrcVer比对比版本DestVer高则1，如果对比版本比原版本高则-1
//  SplitVer(SrcVer, szSrcVer);
//  SplitVer(DestVer, szDestVer);
//  result := CheckVer(szSrcVer, szDestVer);
//end;
//
//function CheckVer(SrcVer, DestVer: TVonVersion): Integer;
//begin
//  result := SrcVer.Int - DestVer.Int;
//end;
//
function SameVer(SrcVer: string; var DestVer: string): Boolean;
var
  szSrc, szDest: TVonList;
  I: Integer;
begin // 如果两个版本一样则返回True，否则为false
  result := false;
  szSrc := TVonList.Create;
  szDest := TVonList.Create;
  szSrc.Delimiter := '.';
  szSrc.Text := SrcVer;
  szDest.Delimiter := '.';
  szDest.Text := DestVer;
  try
    for I := szSrc.Count - 1 downto 0 do
      if szSrc[I] = '*' then
        szDest.Delete(I)
      else if (szSrc[I] <> szDest[I]) then
        Exit;
    DestVer := szDest.Text;
  finally
    szSrc.Free;
    szDest.Free;
  end;
  result := True;
end;

{ 缓存各种信息 }

function SetFont(Font: TFont; const Settings: string): Boolean;
var
  szList: TVonSetting;
  S: string;
begin
  if Settings = '' then
    Exit;
  szList := TVonSetting.Create;
  szList.Text[VSK_SEMICOLON] := Settings;
  with szList do
    try
      S := NameValue['FontStyle'];
      Font.Style := [];
      if Pos('Bold', S) > 0 then
        Font.Style := Font.Style + [fsBold];
      if Pos('Italic', S) > 0 then
        Font.Style := Font.Style + [fsItalic];
      if Pos('Underline', S) > 0 then
        Font.Style := Font.Style + [fsUnderline];
      if Pos('StrikeOut', S) > 0 then
        Font.Style := Font.Style + [fsStrikeOut];
      Font.Name := NameValue['FontName'];
      Result:= Font.Size <> StrToInt(NameValue['FontSize']);
      Font.Size := StrToInt(NameValue['FontSize']);
      Font.Color := StrToInt(NameValue['FontColor']);
      Font.Charset := TFontCharset(StrToInt(NameValue['FontCharset']));
      Font.Height := StrToInt(NameValue['FontHeight']);
      Font.Orientation := StrToInt(NameValue['FontOrientation']);
      Font.Pitch := TFontPitch(StrToInt(NameValue['FontPitch']));
      Font.Quality := TFontQuality(StrToInt(NameValue['FontQuality']));
    finally
      Free;
    end;
end;

function GetFont(Font: TFont): string;
var
  S: string;
begin
  if fsBold in Font.Style then
    S := S + ',Bold';
  if fsItalic in Font.Style then
    S := S + ',Italic';
  if fsUnderline in Font.Style then
    S := S + ',Underline';
  if fsStrikeOut in Font.Style then
    S := S + ',StrikeOut';
  result := 'FontName(' + Font.Name + ')FontSize(' + IntToStr(Font.Size) +
    ')FontStyle(' + S + ')FontCharset(' + IntToStr(Font.Charset) + ')FontColor('
    + IntToStr(Font.Color) + ')FontHeight(' + IntToStr(Font.Height) +
    ')FontOrientation(' + IntToStr(Font.Orientation) + ')FontPitch(' +
    IntToStr(Ord(Font.Pitch)) + ')FontQuality(' +
    IntToStr(Ord(Font.Quality)) + ')';
end;

{ Other }

function GetNewGuid(): TGUID;
begin
  CreateGUID(Result);
end;

function GetNewID(): string;
var // 返回一个24位码
  GUID: TGUID;
  MaxInt: Int64;
begin
  CreateGUID(GUID);
  MaxInt := GUID.d4[0] * GUID.d4[1] * GUID.d4[2] * GUID.d4[3] * GUID.d4[4] *
    GUID.d4[5] * GUID.d4[6] * GUID.d4[7];
  result := IntToHex(GUID.d1, 8) + IntToHex(GUID.d2, 4) + IntToHex(GUID.d3, 4) +
    IntToHex(MaxInt, 8);
end;

function GetGUIDStr(): string;
var // 返回一个24位码
  GUID: TGUID;
begin
  CreateGUID(GUID);
  result := GuidToString(GUID);
end;

function GetGUID(): TGUID;
begin
  CreateGUID(result);
end;

function GUIDToStr(Guid: TGUID): string;
begin
  SetLength(Result, 32);
  StrLFmt(PChar(Result), 38,'%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x',   // do not localize
    [Guid.D1, Guid.D2, Guid.D3, Guid.D4[0], Guid.D4[1], Guid.D4[2], Guid.D4[3],
    Guid.D4[4], Guid.D4[5], Guid.D4[6], Guid.D4[7]]);
end;

function StrToGUID(S: string): TGUID;
begin
  if ((Length(S) = 38) and (s[1] = '{')) then Result:= StringToGuid(S)
  else if Length(S) = 36 then Result:= StringToGuid('{' + S + '}')
  else if Length(S) = 32 then begin
    Result.D1:= HexToInt(Copy(S, 1, 8));
    Result.D2:= HexToInt(Copy(S, 9, 4));
    Result.D3:= HexToInt(Copy(S, 13, 4));
    Result.D4[0]:= HexToInt(Copy(S, 17, 2));
    Result.D4[1]:= HexToInt(Copy(S, 19, 2));
    Result.D4[2]:= HexToInt(Copy(S, 21, 2));
    Result.D4[3]:= HexToInt(Copy(S, 23, 2));
    Result.D4[4]:= HexToInt(Copy(S, 25, 2));
    Result.D4[5]:= HexToInt(Copy(S, 27, 2));
    Result.D4[6]:= HexToInt(Copy(S, 29, 2));
    Result.D4[7]:= HexToInt(Copy(S, 31, 2));
  end else begin
    Result:= TGUID.Empty;             //['{ED799312-2712-46BB-91D8-36DC9457BA87}']
    Result.D1:= HexToInt(S);
  end;
end;

function GuidComp(Guid1, Guid2: TGUID): boolean;
begin
  Result:= CompareMem(@guid1, @guid2, SizeOf(TGUID));
end;
/// <summary>根据GUID值定位一个PGuid的Object的ComboBox值</summary>
function IndexOfGuid(AComboBox: TComboBox; G: TGuid): Integer;
var
  I: Integer;
begin
  Result:= -1;
  for I := 0 to AComboBox.Items.Count - 1 do
    if G = PGuid(AComboBox.Items.Objects[I])^then begin
      Result:= I;
      Exit;
    end;
end;

function iff(condition: Boolean; A: string; B: string): string;
begin
  if condition then Result:= A else Result:= B;
end;

procedure RandomNums(FromValue: Integer; LenBit, KeyValue: Cardinal;
  List: PArrayInt);
var
  szValue, szlen, szKey: UInt64;
  I, J: Cardinal;
begin
  szKey := PrimeNumbers[KeyValue mod 256];
  szlen := (256 shl (LenBit + 1)) - FromValue; // $100
  SetLength(List^, (szlen shr 1) * SizeOf(Cardinal));
  szValue:= szKey;
  for I := 1 to szlen shr 1 do
  begin
    szValue := (szKey * szValue) mod szlen + FromValue;
    List^[I - 1] := szValue;
  end;
end;

procedure CheckPrevInstance(ClassName: string);
var
  Handle, Ret: HWND;
begin
  Handle := CreateMutex(nil, false, PChar(ClassName));
  // 如果之前已经运行了一个实例
  if GetLastError = ERROR_ALREADY_EXISTS then
  begin
    Handle := FindWindow(PChar(ClassName), nil);
    ShowWindow(Handle, SW_RESTORE);
    BringWindowToTop(Handle);
    SetForegroundWindow(Handle);
    Halt;
  end;
end;

function CalcDistance(Lon1: Integer; Lonc1: Double; Lat1: Integer;
  Latc1: Double; Lon2: Integer; Lonc2: Double; Lat2: Integer;
  Latc2: Double): Double;
var
  AHAngle, AVAngle, BHAngle, BVAngle: Double;
  dAlpha, dBeta, dTheta, dCosResult, dResult: Double;
begin // Compute distance of space long
  AHAngle := Lat1 + Latc1 / 60;
  AVAngle := Lon1 + Lonc1 / 60;
  BHAngle := Lat2 + Latc2 / 60;
  BVAngle := Lon2 + Lonc2 / 60;
  dTheta := ABS(AVAngle - BVAngle);
  if (dTheta - 180.00 > 0) then
    dTheta := 360.0 - dTheta;
  dAlpha := AHAngle / 180.0 * PI;
  dBeta := BHAngle / 180.0 * PI;
  dTheta := dTheta / 180.0 * PI;
  dCosResult := cos(dAlpha) * cos(dBeta) * cos(dTheta) + sin(dAlpha) *
    sin(dBeta);
  dResult := arccos(dCosResult); // dResult ranges [0,Pi],needn't change
  result := 6378137 * dResult;
end;

function CalcEarthDistance(Lon1: Double; Lat1: Double; Lon2: Double;
  Lat2: Double): Double;
var
  dAlpha, dBeta, dTheta, dCosResult, dResult: Double;
begin
  dTheta := ABS(Lon1 - Lon2);
  if (dTheta - 180.00 > 0) then
    dTheta := 360.0 - dTheta;
  dAlpha := Lat1 / 180.0 * PI;
  dBeta := Lat2 / 180.0 * PI;
  dTheta := dTheta / 180.0 * PI;
  dCosResult := cos(dAlpha) * cos(dBeta) * cos(dTheta) + sin(dAlpha) *
    sin(dBeta);
  dResult := arccos(dCosResult); // dResult ranges [0,Pi],needn't change
  result := 6378137 * dResult;
end;

function CalcSunRaise(Lon1: Double; Lat1: Double; Date: TDate): TDatetime;
const
  π = 3.14159265;
var
  days: Cardinal; //days从格林威治时间公元2000年1月1日到计算日天数,UTo为上次计算的日出日落时间
  TimeZone: TTimeZoneInformation;
  t, l, g, λ, ε, δ, GHA, e, UTo, UT: Extended;
begin
//  日出日落时太阳的位置h＝-0.833°,要计算地的地理位置,经度Long,纬度G1at,时区zone,UTo为上次计算的日出日落时间,第一次计算时UTo＝180°。
//　(1)先计算出从格林威治时间公元2000年1月1日(36526)到计算日天数days;
  days:= Trunc(Date) - 36525;
//　(2)计算从格林威治时间公元2000年1月1日到计算日的世纪数t,t＝(days+UTo／360)／36525;
  GetTimeZoneInformation(TimeZone);
  UT:= 180;
  repeat
  UTo:= UT;
  t:= (days + UTo/360)/36525;
//　(3)计算太阳的平黄径L=280.460+36000.770×t;
  l:= 280.460+36000.770*t;
//　(4)计算太阳的平近点角 G＝357.528+35999.050×t
  G:=357.528+35999.050*t;
//　(5)计算太阳的黄道经度 λ＝L+1.915×sinG+0.020xsin(2G);
  λ:=L+1.915*sin(G/180*π)+0.020*sin(2*G/180*π);
//　(6)计算地球的倾角ε＝23.4393-0.0130×t;
  ε:=23.4393-0.0130*t;
//　(7)计算太阳的偏差δ＝arcsin(sinε×sinλ);
  δ:=arcsin(sin(ε/180*π)*sin(λ/180*π))*180/π;
//　(8)计算格林威治时间的太阳时间角GHA： GHA=UTo-180-1.915×sinG-0.020×sin(2G) +2.466×sin(2λ)-0.053×sin(4λ)
  GHA:= UTo-180-1.915*sin(G/180*π)-0.020*sin(2*G/180*π)+2.466*sin(2*λ/180*π)-0.053*sin(4*λ/180*π);
//　(9)计算修正值e： e=arcos{[ sinh-sin(Glat)sin(δ)]/cos(Glat)cos(δ)}
  e:=ArcCos((sin(-0.833/180*π)-sin(Lat1/180*π)*sin(δ/180*π))/cos(Lat1/180*π)/cos(δ/180*π))*180/π;
  UT:= UTo-(GHA+Lon1+e);
  until ABS(UT - UTo) <= 0.1;
//　(10)计算新的日出日落时间
//　UT＝UTo-(GHA+Long±e);
//　其中“+”表示计算日出时间,“-”表示计算日落时间;
//　(11)比较UTo和UT之差的绝对值,如果大于0.1°即0.007小时,把UT作为新的日出日落时间值,重新从第(2)步开始进行迭代计算,如果UTo和UT之差的绝对值小于0.007小时,则UT即为所求的格林威治日出日落时间;
//　(12)上面的计算以度为单位,即180°=12小时,因此需要转化为以小时表示的时间,再加上所在的时区数Zone,即要计算地的日出日落时间为 T=UT/15+Zone
  Result:= (UT/15+(TimeZone.Bias div -60))/24;
//　上面的计算日出日落时间方法适用于小于北纬60°和南纬60°之间的区域,如果计算位置为西半球时,经度Long为负数。
end;

function CalcSunset(Lon1: Double; Lat1: Double; Date: TDate): TDatetime;
const
  π = 3.14159265;
var
  days: Cardinal; //days从格林威治时间公元2000年1月1日到计算日天数,UTo为上次计算的日出日落时间
  TimeZone: TTimeZoneInformation;
  t, l, g, λ, ε, δ, GHA, e, UTo, UT: Extended;
begin
//  日出日落时太阳的位置h＝-0.833°,要计算地的地理位置,经度Long,纬度G1at,时区zone,UTo为上次计算的日出日落时间,第一次计算时UTo＝180°。
//　(1)先计算出从格林威治时间公元2000年1月1日(32526)到计算日天数days;
//  ShowMessage(IntToStr(Trunc(encodedate(2000,1,1))));
  days:= Trunc(Date) - 36525;
//　(2)计算从格林威治时间公元2000年1月1日到计算日的世纪数t,t＝(days+UTo／360)／36525;
  GetTimeZoneInformation(TimeZone);
  UT:= 180;
  repeat
  UTo:= UT;
  t:= (days + UTo/360)/36525;
//　(3)计算太阳的平黄径L=280.460+36000.770×t;
  l:= 280.460+36000.770*t;
//　(4)计算太阳的平近点角 G＝357.528+35999.050×t
  G:=357.528+35999.050*t;
//　(5)计算太阳的黄道经度 λ＝L+1.915×sinG+0.020xsin(2G);
  λ:=L+1.915*sin(G/180*π)+0.020*sin(2*G/180*π);
//　(6)计算地球的倾角ε＝23.4393-0.0130×t;
  ε:=23.4393-0.0130*t;
//　(7)计算太阳的偏差δ＝arcsin(sinε×sinλ);
  δ:=arcsin(sin(ε/180*π)*sin(λ/180*π))*180/π;
//　(8)计算格林威治时间的太阳时间角GHA： GHA=UTo-180-1.915×sinG-0.020×sin(2G) +2.466×sin(2λ)-0.053×sin(4λ)
  GHA:= UTo-180-1.915*sin(G/180*π)-0.020*sin(2*G/180*π)+2.466*sin(2*λ/180*π)-0.053*sin(4*λ/180*π);
//　(9)计算修正值e： e=arcos{[ sinh-sin(Glat)sin(δ)]/cos(Glat)cos(δ)}
  e:=ArcCos((sin(-0.833/180*π)-sin(Lat1/180*π)*sin(δ/180*π))/cos(Lat1/180*π)/cos(δ/180*π))*180/π;
  UT:= UTo-(GHA+Lon1-e);
  until ABS(UT - UTo) <= 0.1;
//　(10)计算新的日出日落时间
//　UT＝UTo-(GHA+Long±e);
//　其中“+”表示计算日出时间,“-”表示计算日落时间;
//　(11)比较UTo和UT之差的绝对值,如果大于0.1°即0.007小时,把UT作为新的日出日落时间值,重新从第(2)步开始进行迭代计算,如果UTo和UT之差的绝对值小于0.007小时,则UT即为所求的格林威治日出日落时间;
//　(12)上面的计算以度为单位,即180°=12小时,因此需要转化为以小时表示的时间,再加上所在的时区数Zone,即要计算地的日出日落时间为 T=UT/15+Zone
  Result:= (UT/15+(TimeZone.Bias div -60))/24;
//　上面的计算日出日落时间方法适用于小于北纬60°和南纬60°之间的区域,如果计算位置为西半球时,经度Long为负数。
end;

procedure GetFiles(Dir, Ext: string; Items: TStrings;
  IncludeSubDir: Boolean = false);
var
  sr: TSearchRec;
  FileAttrs: Integer;
begin
  FileAttrs := faDirectory + faArchive + faAnyFile;
  if SysUtils.FindFirst(Dir + '\*.*', FileAttrs, sr) = 0 then
    repeat
      if (sr.Attr and faDirectory > 0) and IncludeSubDir then
        GetFiles(sr.Name, Ext, Items, True)
      else if (sr.Attr and FileAttrs > 0) and
        (ExtractFileExt(sr.Name) = Ext) then
        Items.Add(sr.Name);
    until SysUtils.FindNext(sr) <> 0;
  SysUtils.FindClose(sr);
end;

function GetFileName(Filename: string): string;
var
  I: Integer;
begin
  I := LastDelimiter(PathDelim + DriveDelim, FileName);
  Result := Copy(FileName, I + 1, MaxInt);
  I := LastDelimiter('.' + PathDelim + DriveDelim, Result);
  if (I > 0) and (Result[I] = '.') then
    Result := Copy(Result, 1, I - 1);
end;

procedure DirCopy(ASourceDir:String; ADestDir:String);
var
  FileRec: TSearchrec;
  Sour, Dest: String;
begin
  Sour:=ASourceDir;
  Dest:=ADestDir;
  if Sour[Length(Sour)]<>'\' then Sour := Sour + '\';
  if Dest[Length(Dest)]<>'\' then Dest := Dest + '\';
  if not DirectoryExists(ASourceDir) then
    raise Exception.Create('来源目录不存在!!');
  if not DirectoryExists(ADestDir) then
    ForceDirectories(ADestDir);
  if FindFirst(Sour + '*.*', faAnyfile, FileRec) = 0 then
  repeat
    if ((FileRec.Attr and faDirectory) <> 0) then
    begin
      if (FileRec.Name<>'.') and (FileRec.Name<>'..') then
      begin
        DirCopy(Sour+FileRec.Name,Dest+FileRec.Name);
      end;
    end
    else
    begin
      CopyFile(PChar(Sour + FileRec.Name), PChar(Dest + FileRec.Name), false);
    end;
  until FindNext(FileRec) <> 0;
  SysUtils.FindClose(FileRec);
end;

procedure CreateDirectory(dir: string);
var
  path: TStringDynArray;
  szDir: string;
  I: Integer;
begin
  path := SplitString(dir, '\');
  szDir:= path[0];
  for I := 1 to Length(path) - 1 do
  begin
    szDir:= szDir + '\' + path[I];
    if not DirectoryExists(szDir) then
      CreateDir(szDir);
  end;
end;

function LongToShortFilePath(const LongName: string): string;
begin
  SetLength(Result, WinAPI.Windows.MAX_PATH);
  SetLength(
    Result,
    winapi.Windows.GetShortPathName(
      PChar(LongName), PChar(Result), winapi.Windows.MAX_PATH
    )
  );
end;

(* Component functions *)

Procedure ComponentKeyPress(DataType: string; var Key: Char);
var
  upDataType: string;
begin // Check key, if it is vaild, then return true, else return false.
  upDataType := UpperCase(DataType);
  if (upDataType = 'INT') or (upDataType = 'INTEGER') then
  begin
    if not(Key in ['0' .. '9', #13]) then
      Key := Char(0);
  end
  else if (upDataType = 'REAL') or (upDataType = 'FLOAT') then
  begin
    if not(Key in ['0' .. '9', '.']) then
      Key := Char(0);
  end;
end;
/// <summary>整数Edit录入保护函数</summary>
procedure EventOfIntEditKeyPress(Sender: TEdit; var Key: Char);
var
  val: Integer;
begin
  if Key = #8 then Exit;
  if not tryStrToInt(Key + Sender.Text, Val) then
    Key:= #0;
end;
/// <summary>浮点Edit录入保护函数</summary>
procedure EventOfFloatEditKeyPress(Sender: TEdit; var Key: Char);
var
  val: Extended;
begin
  if Key = #8 then Exit;
  if not tryStrToFloat(Sender.Text + Key, Val) then
    Key:= #0;
end;
/// <summary>Edit录入框，箭头或回车跳转函数，用于Edit的KeyDown事件</summary>
procedure EventOfMoveEditKeyDown(Sender: TEdit; var Key: Word; Shift: TShiftState);
var
  lst: TList;
  ctrl: TWinControl;
begin
  if Sender.SelLength > 0 then Exit;
  if((Key = 13)or(Key = 39)or(Key = 40))and((Sender.SelStart = Length(Sender.Text)))then begin
    lst:= TList.Create;
    Sender.Parent.GetTabOrderList(lst);
    if Sender.TabOrder + 1 < lst.Count then
      TWinControl(lst[Sender.TabOrder + 1]).SetFocus;
    lst.Free;
  end else if(TEdit(Sender).SelStart = 0)and(Sender.TabOrder - 1 >= 0)and((Key = 37)or(Key = 38))then begin
    lst:= TList.Create;
    Sender.Parent.GetTabOrderList(lst);
    TWinControl(lst[Sender.TabOrder - 1]).SetFocus;
    lst.Free;
  end;
end;

function GetMutiChkByChkList(AList: TCheckListBox): Int64;
var
  I: Integer;
  AResult: Int64;
begin
  AResult := 1;
  result := 0;
  for I := 0 to AList.Count - 1 do
  begin
    if AList.Checked[I] then
      result := result + AResult;
    AResult := AResult * 2;
  end;
end;

procedure SetMutiChkToChkList(AValue: Int64; AList: TCheckListBox);
var
  I: Integer;
begin
  for I := 0 to AList.Count - 1 do
    AList.Checked[I] := (AValue shr I) and 1 > 0;
end;

procedure GetMutiChkByChkList(var AValue: array of Byte; AList: TCheckListBox);
var
  I, L, H: Integer;
begin // 根据记录整数（二进制记忆方式）回选TCheckListBox的内容
  for I := 0 to AList.Count - 1 do
  begin
    L := I mod 8;
    H := I div 8;
    if AList.Checked[I] then
      AValue[H] := AValue[H] or (1 shl L)
    else
      AValue[H] := AValue[H] and (not(1 shl L));
  end;
end;

procedure SetMutiChkToChkList(AValue: array of Byte; AList: TCheckListBox);
var
  I, L, H: Integer;
begin
  for I := 0 to AList.Count - 1 do
  begin
    L := I mod 8;
    H := I div 8;
    AList.Checked[I] := (AValue[H] and (1 shl L)) > 0;
  end;
end;

function GetMutiChkString(AList: TCheckListBox): string;
var
  I: Integer;
begin // 根据选择结果将结果以文字方式显示出来，中间以逗号间隔
  result := '';
  for I := 0 to AList.Count - 1 do
    if AList.Checked[I] then
      result := result + ',' + AList.Items[I];
  if result <> '' then
    Delete(result, 1, 1);
end;

procedure SetMutiChkString(AList: TCheckListBox; Value: string);
var
  mPos: Integer;

  procedure ChkIt(ItemValue: string);
  var
    Idx: Integer;
  begin
    Idx := AList.Items.IndexOf(ItemValue);
    if Idx >= 0 then
      AList.Checked[Idx] := True;
  end;

begin
  AList.CheckAll(cbUnchecked);
  mPos := Pos(',', Value);
  while mPos > 0 do
  begin
    ChkIt(Copy(Value, 1, mPos - 1));
    Delete(Value, 1, mPos);
    mPos := Pos(',', Value);
  end;
  ChkIt(Value);
end;

/// <summary>得到列表组件中的Object整数值</summary>
function GetListObjectValue(AListBox: TCustomCombo): Integer;
begin
  Result:= Integer(AListBox.Items.Objects[AListBox.ItemIndex]);
end;

procedure DBGridAutoFixWidth(objDBGrid: TDBGrid);
var
  cc:integer;
  i,tmpLength:integer;
  objDataSet: TDataSet;
  aDgCLength:array of integer;
begin
  cc:=objDbGrid.Columns.Count-1;
  objDataSet:=objDbGrid.DataSource.DataSet;
  setlength(aDgCLength,cc+1);
  for i:=0 to cc do begin
    aDgCLength[i]:= length(objDbGrid.Columns[i].Title.Caption);
  end;
  objDataSet.First;
  while not objDataSet.Eof do begin
    for i:=0 to cc do begin
      tmpLength:=length(objDataSet.Fields.Fields[i].AsString);
      if tmpLength>aDgCLength[i]
        then aDgCLength[i]:=tmpLength;
    end;
    objDataSet.Next;
  end;
  for i:=0 to cc do begin
    objDbGrid.Columns[i].Width:=(aDgCLength[i])*7;
  end;
  objDataSet.First;
end;

{ multi language }

type
  TAsInheritedReader = class(TReader)
  public
    procedure ReadPrefix(var Flags: TFilerFlags;
      var AChildPos: Integer); override;
  end;

procedure TAsInheritedReader.ReadPrefix(var Flags: TFilerFlags;
  var AChildPos: Integer);
begin
  inherited ReadPrefix(Flags, AChildPos);
  Include(Flags, ffInherited);
end;

function SetResourceHInstance(NewInstance: Longint): Longint;
var
  CurModule: PLibModule;
begin
  CurModule := LibModuleList;
  result := 0;
  while CurModule <> nil do
  begin
    if CurModule.Instance = HInstance then
    begin
      if CurModule.ResInstance <> CurModule.Instance then
        FreeLibrary(CurModule.ResInstance);
      CurModule.ResInstance := NewInstance;
      result := NewInstance;
      Exit;
    end;
    CurModule := CurModule.Next;
  end;
end;

function LoadNewResourceModule(Locale: LCID): Longint;
var
  FileName: array [0 .. 260] of Char;
  P: PChar;
  LocaleName: array [0 .. 4] of Char;
  NewInst: Longint;
begin
  GetModuleFileName(HInstance, FileName, SizeOf(FileName));
  GetLocaleInfo(Locale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));
  P := PChar(@FileName) + lstrlen(FileName);
  while (P^ <> '.') and (P <> @FileName) do
    Dec(P);
  NewInst := 0;
  result := 0;
  if P <> @FileName then
  begin
    Inc(P);
    if LocaleName[0] <> #0 then
    begin
      // Then look for a potential language/country translation
      lstrcpy(P, LocaleName);
      NewInst := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
      if NewInst = 0 then
      begin
        // Finally look for a language only translation
        LocaleName[2] := #0;
        lstrcpy(P, LocaleName);
        NewInst := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
      end;
    end;
  end;
  if NewInst <> 0 then
    result := SetResourceHInstance(NewInst)
end;

function InternalReloadComponentRes(const ResName: string; HInst: THandle;
  var Instance: TComponent): Boolean;
var
  HRsrc: THandle;
  ResStream: TResourceStream;
  AsInheritedReader: TAsInheritedReader;
begin { avoid possible EResNotFound exception }
  if HInst = 0 then
    HInst := HInstance;
  HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);
  result := HRsrc <> 0;
  if not result then
    Exit;
  ResStream := TResourceStream.Create(HInst, ResName, RT_RCDATA);
  try
    AsInheritedReader := TAsInheritedReader.Create(ResStream, 4096);
    try
      Instance := AsInheritedReader.ReadRootComponent(Instance);
    finally
      AsInheritedReader.Free;
    end;
  finally
    ResStream.Free;
  end;
  result := True;
end;

function ReloadInheritedComponent(Instance: TComponent;
  RootAncestor: TClass): Boolean;

  function InitComponent(ClassType: TClass): Boolean;
  begin
    result := false;
    if (ClassType = TComponent) or (ClassType = RootAncestor) then
      Exit;
    result := InitComponent(ClassType.ClassParent);
    result := InternalReloadComponentRes(ClassType.ClassName,
      FindResourceHInstance(FindClassHInstance(ClassType)), Instance) or result;
  end;

begin
  result := InitComponent(Instance.ClassType);
end;

procedure ReinitializeForms;
var
  Count: Integer;
  I: Integer;
  Form: TForm;
begin
  Count := Screen.FormCount;
  for I := 0 to Count - 1 do
  begin
    Form := Screen.Forms[I];
    ReloadInheritedComponent(Form, TForm);
  end;
end;

{ 图像信息处理部分 }

procedure SaveImages(FileName: string; ImgList: TImageList);
var
  szOutBmp, aBmp: TBitmap;
  I: Integer;
begin // 保存图标
  szOutBmp := TBitmap.Create;
  szOutBmp.Width := ImgList.Width * ImgList.Count;
  szOutBmp.Height := ImgList.Height;
  aBmp := TBitmap.Create;
  for I := 0 to ImgList.Count - 1 do
  begin
    aBmp.Canvas.FillRect(Rect(0, 0, ImgList.Width, ImgList.Height));
    ImgList.GetBitmap(I, aBmp);
    szOutBmp.Canvas.Draw(I * ImgList.Width, 0, aBmp);
  end;
  szOutBmp.SaveToFile(FileName);
  aBmp.Free;
  szOutBmp.Free;
end;

procedure LoadImages(FileName: string; ImgList: TImageList; imgHeight: Integer = 0; imgWidth: Integer = 0);
var
  szOutBmp: TBitmap;
begin // 提取图标
  szOutBmp := TBitmap.Create;
  szOutBmp.LoadFromFile(FileName);
  ImgList.Clear;
  if imgHeight = 0 then
    ImgList.Height := szOutBmp.Height
  else ImgList.Height := imgHeight;
  if imgWidth = 0 then
    ImgList.Width := szOutBmp.Height
  else ImgList.Width := imgWidth;
  ImgList.AddMasked(szOutBmp, szOutBmp.Canvas.Pixels[0,0]); // szOutBmp);
  ImgList.Masked:= True;
  szOutBmp.Free;
end;

procedure LoadGraphicFile(FileName: string; var Bmp: TBitmap;
  DefineWidth, DefineHeight: Integer);
var
  Pic: TPicture;
begin
  Pic := TPicture.Create;
  with Pic do
    try
      LoadFromFile(FileName);
      if (DefineWidth > 0) and (DefineHeight > 0) then
      begin
        Bmp.Width := DefineWidth;
        Bmp.Height := DefineHeight;
        Bmp.Canvas.StretchDraw(Rect(0, 0, DefineWidth, DefineHeight),
          Pic.Graphic);
      end
      else
        Bmp.Assign(Pic.Graphic);
    finally
      Pic.Free;
    end;
end;

///读取资源文件中的位图信息，例如：Image1.Picture.Bitmap.Handle:=GetResBitmap('OPEN');
function GetResBitmap(const ResName: string): HBitmap;
begin
  Result:= LoadBitmap(hinstance, PChar(ResName));
end;

///将Bitmap位图转化为base64字符串
function BitmapToString(img:TBitmap):string ;
var
  ms:TMemoryStream;
  ss:TStringStream;
  s:string;
begin
    ms := TMemoryStream.Create;
    img.SaveToStream(ms);
    ss := TStringStream.Create('');
    ms.Position:=0;
    EncodeStream(ms,ss);//将内存流编码为base64字符流
    s:=ss.DataString;
    ms.Free;
    ss.Free;
    result:=s;
end;

///将base64字符串转化为Bitmap位图
procedure StringToBitmap(imgStr: string; Bmp: TBitmap);
var ss:TStringStream;
    ms:TMemoryStream;
begin
    ss := TStringStream.Create(imgStr);
    ms := TMemoryStream.Create;
    DecodeStream(ss,ms);//将base64字符流还原为内存流
    ms.Position:=0;
    Bmp.LoadFromStream(ms);
    ss.Free;
    ms.Free;
end;

function NextColor(AColor: TColor; ARate: Extended): TColor;
var
  C: TColorRef;
  function GetD(A: byte; luminance: Double): byte;
  var
    szP: Double;
  begin
    szP:= (Random(15) + $40) * luminance;
    Result:= Round(A + szP) mod 256;
  end;
begin
  if AColor = 0 then AColor:= FCurrentColor;
  C:= ColorToRGB(AColor);
  FCurrentColor:= RGB(GetD(GetGValue(C), 0.25), GetD(GetBValue(C), 0.625), GetD(GetRValue(C), 0.125));
  Result:= FCurrentColor;
end;

function FontColor(BackColor: TColor = 0): TColor;
var
  luminance: Double;
begin
  if BackColor = 0 then BackColor:= FCurrentColor;
  luminance:= GetRValue(BackColor) * 0.25 + GetGValue(BackColor) * 0.625
          + GetBValue(BackColor) * 0.125;
  if luminance < 128 then Result:= clWindow
  else Result:= clBlack;
end;

{ SQL generator }

function GeneratorSql(Qualifier, Fields: string;
  Event: TEventOfLinkTable): string;
var
  szS: string;
  szList: TVonSetting;
  I: Integer;
begin
  result := 'SELECT ' + Fields;
  szS := ReplaceStr(Fields, '.', '=');
  szList := TVonSetting.Create;
  szList.Text[VSK_COMMA] := szS;
  result := result + ' FROM ' + Qualifier + szList.Names[0] + ' ' +
    szList.Names[0];
  for I := 1 to szList.Count - 1 do
    result := result + ' JOIN ' + Qualifier + szList.Names[I] + ' ' +
      szList.Names[I] + ' ON ' + Event(szList.Names[0], szList.Names[I]);
  szList.Free;
end;

function GeneratorCondition(FieldName, Condition: string): string;
var
  P: PChar;
  flag, Linker, S: string;
  procedure AddCondition;
  begin
    if flag = '' then Result:= Result + ' ' + Linker + ' ' + FieldName + '=' + S
    else Result:= Result + ' ' + Linker + ' ' + FieldName + flag + S;
    S:= ''; flag:= '';
  end;
begin
  P:= PChar(Condition);
  flag:= '='; Linker:= ''; Result:= '';
  while P^ <> #0 do begin
    case P^ of
    '<', '>', '=': flag:= flag + P^;
    ',': begin AddCondition; Linker:= 'AND'; end;
    '|': begin AddCondition; Linker:= 'OR'; end;
    '(', ')': Result:= Result + P^;
    else S:= S + P^;
    end;
    Inc(P);
  end;
  if S <> '' then AddCondition;
end;

procedure AddRangeCondition(AQuery: TADOQuery; E1, E2: TCustomEdit;
  FieldName: string);
var
  f: Extended;
begin
  if (E1.Text <> '') and TryStrToFloat(E1.Text, f) and (f > 0) then
  begin // Diameter
    if (E2.Text <> '') and TryStrToFloat(E2.Text, f) and (f > 0) then
    begin
      AQuery.SQL.Add('AND ' + FieldName + '>=' + E1.Text);
      AQuery.SQL.Add('AND ' + FieldName + '<=' + E2.Text);
    end
    else
      AQuery.SQL.Add('AND ' + FieldName + '=' + E1.Text);
  end
  else if (E2.Text <> '') and TryStrToFloat(E2.Text, f) and (f > 0) then
    AQuery.SQL.Add('AND ' + FieldName + '<=' + E2.Text);
end;

procedure AddRangeCondition(AQuery: TADOQuery; E1, E2: TSpinEdit;
  FieldName: string);
var
  f: Extended;
begin
  if (E1.Value > 0) then
  begin // Diameter
    if (E2.Value > 0) then
    begin
      AQuery.SQL.Add('AND ' + FieldName + '>=' + IntToStr(E1.Value));
      AQuery.SQL.Add('AND ' + FieldName + '<=' + IntToStr(E2.Value));
    end
    else
      AQuery.SQL.Add('AND ' + FieldName + '=' + IntToStr(E2.Value));
  end
  else if (E2.Value > 0) then
    AQuery.SQL.Add('AND ' + FieldName + '<=' + IntToStr(E2.Value));
end;

procedure AddRangeCondition(AQuery: TADOQuery; E1, E2: TDateTimePicker;
  FieldName: string);
begin
  if E1.Checked then begin
    if E1.Kind = dtkDate then
      AQuery.SQL.Add('AND ' + FieldName + '>=''' + DateToStr(E1.Date) + '''')
    else AQuery.SQL.Add('AND ' + FieldName + '>=''' + TimeToStr(E1.Time) + '''');
  end;
  if E2.Checked then begin
    if E1.Kind = dtkDate then
      AQuery.SQL.Add('AND ' + FieldName + '<''' + DateToStr(E2.Date + 1) + '''')
    else AQuery.SQL.Add('AND ' + FieldName + '<''' + TimeToStr(IncSecond(E2.Time, 1)) + '''');
  end;
end;

procedure AddRangeCondition(AQuery: TADOQuery; Val1, Val2: Extended;
  FieldName: string);
begin
  if (Val1 > 0) then begin // Diameter
    if (Val2 > 0) then
    begin
      AQuery.SQL.Add('AND ' + FieldName + '>=' + FloatToStr(Val1));
      AQuery.SQL.Add('AND ' + FieldName + '<=' + FloatToStr(Val2));
    end
    else
      AQuery.SQL.Add('AND ' + FieldName + '=' + FloatToStr(Val2));
  end else if (Val2 > 0) then
    AQuery.SQL.Add('AND ' + FieldName + '<=' + FloatToStr(Val2));
end;

{ Config file functions }
procedure RegAppConfig(SectionName, IdentName, ConfigInfo: string;
  DataType: TVonListInputDataType; Params, DefaultValue: string; Help: string);
begin
  FAppConfigList.AppendRow([SectionName, IdentName, ConfigInfo,
    IntToStr(Ord(DataType)), Params, DefaultValue, DefaultValue, Help]);
end;

function ReadAppConfig(SectionName, IdentName: string): string;
var
  Row: Integer;
begin
  result := '';
  for Row := 0 to FAppConfigList.Count - 1 do
    if SameText(FAppConfigList.Values[Row, 0], SectionName) and
      SameText(FAppConfigList.Values[Row, 1], IdentName) then
    begin
      result := FAppConfigList.Values[Row, 6];
      Exit;
    end;
end;

procedure ReadAppItems(SectionName, IdentName, DefauleValue: string; Items: TStrings);
var
  Row: Integer;
begin
  //SectionName, IdentName, ConfigInfo, DataType, Params, DefaultValue, UserValue, Help
  Items.Delimiter:= ',';
  for Row := 0 to FAppConfigList.Count - 1 do
    if SameText(FAppConfigList.Values[Row, 0], SectionName) and
      SameText(FAppConfigList.Values[Row, 1], IdentName) then
    begin
      Items.DelimitedText := FAppConfigList.Values[Row, 6];
      Exit;
    end;
  Items.DelimitedText := DefauleValue;
end;

function ReadAppSetting(SectionName, IdentName: string; Items: TStrings): Integer;
var
  Row: Integer;
begin
  Result:= -1;
  Items.Delimiter:= ',';
  for Row := 0 to FAppConfigList.Count - 1 do
    if SameText(FAppConfigList.Values[Row, 0], SectionName) and
      SameText(FAppConfigList.Values[Row, 1], IdentName) then
    begin
      Items.DelimitedText := FAppConfigList.Values[Row, 4];
      Result:= Items.IndexOf(FAppConfigList.Values[Row, 6]);
      Exit;
    end;
  Items.DelimitedText := '';
end;

procedure WriteAppConfig(SectionName, IdentName, Value: string);
var
  Row: Integer;
begin
  for Row := 0 to FAppConfigList.Count - 1 do
    if SameText(FAppConfigList.Values[Row, 0], SectionName) and
      SameText(FAppConfigList.Values[Row, 1], IdentName) then
    begin
      FAppConfigList.Values[Row, 6] := Value;
      Exit;
    end;
end;

(* Runtime *)

procedure RegisteRuntime(Key, Format, DefaultValue: string);
begin
  system_runtime_settings.Values[Key]:= Format;
  SetRuntimeValue(Key, DefaultValue);
end;

function GetRuntimeValue(Key: string): string;
begin
  Result:= system_runtime_value.Values[Key];
end;

procedure SetRuntimeValue(Key: string; const Value: string);
begin
  system_runtime_value.Values[Key]:= Value;
end;

(* Internet *)

function UrlGetStr(const URL: string; ShowHeaders: Boolean = false): string;
const
  Agent = 'Internet Explorer 6.0';
var
  hFile, HInet: HINTERNET;
  Buffer: array [0 .. 32767] of Char;
  BufRead: Cardinal;
  BufSize: Cardinal;
  TempStream: TStringStream;
  dwIndex: DWORD;
begin
  result := '';
  HInet := InternetOpen(PChar(Agent), INTERNET_OPEN_TYPE_PRECONFIG,
    nil, nil, 0);
  if Assigned(HInet) then
    try
      hFile := InternetOpenUrl(HInet, PChar(URL), nil, 0, 0, 0);
      TempStream := TStringStream.Create('');
      dwIndex := 0;
      BufSize := SizeOf(Buffer);
      HttpQueryInfo(hFile, HTTP_QUERY_RAW_HEADERS_CRLF, @Buffer,
        BufSize, dwIndex);
      if ShowHeaders then
        TempStream.Write(Buffer, BufSize);
      if Assigned(hFile) then
        try
          with TempStream do
            try
              while InternetReadFile(hFile, @Buffer, BufSize, BufRead) and
                (BufRead > 0) do
                Write(Buffer, BufRead);
              result := Encoding.UTF8.GetString(Bytes);
            finally
              Free;
            end;
        finally
          InternetCloseHandle(hFile);
        end;
    finally
      InternetCloseHandle(HInet);
    end;
end;

procedure WavBeep(WavFilename: string);
//var
//  OpenParm: TMCI_Open_Parms;
//  PlayParm: TMCI_Play_Parms;
//  SeekParm: TMCI_Seek_Parms;
begin
  //beep(495, 300);  Exit;
  if(WavFilename = '')or(not FileExists(wavFilename))then
    wavFilename := ExtractFilePath(Application.ExeName) + 'beep.wav';
  if FileExists(wavFilename) then
    sndplaysound(PChar(wavFilename),snd_async);
//  if (FMCI_Handel = 1) and (lstWavFilename <> WavFilename) then begin  //(FMCI_Handel = 0)and
//    mciSendCommand(0, mci_Open, MCI_OPEN_ELEMENT, Longint(@OpenParm))
//  end;
//  if FileExists(wavFilename) then   //(FMCI_Handel = 0)and
//  begin
//    FillChar(OpenParm, SizeOf(TMCI_Open_Parms), 0);
//    OpenParm.dwCallback := 0;
//    OpenParm.lpstrDeviceType := 'WaveAudio';
//    OpenParm.lpstrElementName := PWideChar(wavFilename);
//    // mci_Open_Type or mci_Open_Shareable
//    if mciSendCommand(0, mci_Open, MCI_OPEN_ELEMENT, Longint(@OpenParm)) <>
//      0 then { problem opening device }
//      raise EMCIDeviceError.Create('Can not open a wav device.')
//    else
//      FMCI_Handel := OpenParm.wDeviceID; { device successfully opened }
//  end;
//  if FMCI_Handel = 0 then
//    MessageBeep(0)
//  else
//  begin
//    PlayParm.dwFrom := 0;
//    PlayParm.dwTo := 0;
//    PlayParm.dwCallback := Application.Handle;
//    mciSendCommand(FMCI_Handel, mci_Play, MCI_NOTIFY or MCI_FROM,
//      Longint(@PlayParm));
//  end;
end;

procedure PrintLine(Prn, LineText: string);
var
  bResult  : Boolean;
  hPrinter : THandle;
  tDocInfo : _DOC_INFO_1A;
  iWrited  : Cardinal;
  S: AnsiString;
//function  SendDataToPrinter(sDeviceName, sDocName, sData: String): Boolean;
//功能描述: 发送数据到打印机            (Powered by Jadeluo)
//入口参数:
//  sDeviceName - 打印机名称
//  sDocName    - 打印文档名称
//  sData       - 发送的数据
//出口参数:
//  返回值      - True表示成功, False表示失败
begin
  //function OpenPrinter(pPrinterName: LPWSTR; var phPrinter: THandle; pDefault: PPrinterDefaults): BOOL; stdcall;
  bResult := OpenPrinter(PChar(Prn), hPrinter, nil);
  if bResult then
  begin
    S:= '即时打印';
    tDocInfo.pDocName := PAnsiChar(S);
    tDocInfo.pOutputFile := nil;
    tDocInfo.pDatatype := nil;
    bResult := StartDocPrinter(hPrinter, 1, @tDocInfo) <> 0;
    if bResult then
    begin
      bResult := StartPagePrinter(hPrinter);
      S:= LineText + #13#10;
      bResult := bResult and WritePrinter(hPrinter, @S[1], Length(S), iWrited);
      bResult := bResult and EndPagePrinter(hPrinter);
      EndDocPrinter(hPrinter);
    end;
    ClosePrinter(hPrinter);
  end;
end;
/// <summary>检查身份证数据是否有效</summary>
function CheckIdentification(Identification: string): string;
{ 内部函数,取身份证号校验位,最后一位,对18位有效 }
  function GetVerifyBit(sIdentityNum: string): Char;
  var
    nNum: Integer;
  begin
    Result := #0;
    nNum := StrToInt(sIdentityNum[1]) * 7 + StrToInt(sIdentityNum[2]) * 9 +
      StrToInt(sIdentityNum[3]) * 10 + StrToInt(sIdentityNum[4]) * 5 +
      StrToInt(sIdentityNum[5]) * 8 + StrToInt(sIdentityNum[6]) * 4 +
      StrToInt(sIdentityNum[7]) * 2 + StrToInt(sIdentityNum[8]) * 1 +
      StrToInt(sIdentityNum[9]) * 6 + StrToInt(sIdentityNum[10]) * 3 +
      StrToInt(sIdentityNum[11]) * 7 + StrToInt(sIdentityNum[12]) * 9 +
      StrToInt(sIdentityNum[13]) * 10 + StrToInt(sIdentityNum[14]) * 5 +
      StrToInt(sIdentityNum[15]) * 8 + StrToInt(sIdentityNum[16]) * 4 +
      StrToInt(sIdentityNum[17]) * 2;
    nNum := nNum mod 11;
    case nNum of
      0:
        Result := '1';
      1:
        Result := '0';
      2:
        Result := 'X';
      3:
        Result := '9';
      4:
        Result := '8';
      5:
        Result := '7';
      6:
        Result := '6';
      7:
        Result := '5';
      8:
        Result := '4';
      9:
        Result := '3';
      10:
        Result := '2';
    end;
  end;

var
  L: Integer;
  sCentury: string;
  sYear2Bit: string;
  sMonth: string;
  sDate: string;
  iCentury: Integer;
  iMonth: Integer;
  iDate: Integer;
  CRCFact: string; // 18位证号的实际值
  CRCTh: string; // 18位证号的理论值
  FebDayAmt: byte; // 2月天数
begin
  L := Length(Identification);
  if (L in [15, 18]) = False then
  begin
    Result := Format('身份证号不是15位或18位(%0:s, 实际位数:%1:d)', [Identification, L]);
    Exit;
  end;
  CRCFact := '';
  if L = 18 then
  begin
    sCentury := Copy(Identification, 7, 2);
    iCentury := StrToInt(sCentury);
    if (iCentury in [18 .. 20]) = False then
    begin
      Result := Format('身份证号码无效:18位证号的年份前两位必须在18-20之间(%0:S)', [sCentury]);
      Exit;
    end;
    sYear2Bit := Copy(Identification, 9, 2);
    sMonth := Copy(Identification, 11, 2);
    sDate := Copy(Identification, 13, 2);
    CRCFact := Copy(Identification, 18, 1);
  end
  else
  begin
    sCentury := '19';
    sYear2Bit := Copy(Identification, 7, 2);
    sMonth := Copy(Identification, 9, 2);
    sDate := Copy(Identification, 11, 2);
  end;
  iMonth := StrToInt(sMonth);
  iDate := StrToInt(sDate);
  if (iMonth in [01 .. 12]) = False then
  begin
    Result := Format('身份证号码无效:月份必须在01-12之间(%0:s)', [sMonth]);
    Exit;
  end;
  if (iMonth in [1, 3, 5, 7, 8, 10, 12]) then
  begin
    if (iDate in [01 .. 31]) = False then
    begin
      Result := Format('身份证号码无效:日期无效,不能为零或超出当月最大值(%0:s)', [sDate]);
      Exit;
    end;
  end;
  if (iMonth in [4, 6, 9, 11]) then
  begin
    if (iDate in [01 .. 30]) = False then
    begin
      Result := Format('身份证号码无效:日期无效,不能为零或超出当月最大值(%0:s)', [sDate]);
      Exit;
    end;
  end;
  if IsLeapYear(StrToInt(sCentury + sYear2Bit)) = True then
  begin
    FebDayAmt := 29;
  end
  else
  begin
    FebDayAmt := 28;
  end;
  if (iMonth in [2]) then
  begin
    if (iDate in [01 .. FebDayAmt]) = False then
    begin
      Result := Format('身份证号码无效:日期无效,不能为零或超出当月最大值(%0:s)', [sDate]);
      Exit;
    end;
  end;
  if CRCFact <> '' then
  begin
    CRCTh := GetVerifyBit(Identification);
    if CRCFact <> CRCTh then
    begin
      Result := Format('身份证号码无效:校验位(第18位)错:(%0:s)', [Identification]);
      Exit;
    end;
  end;
end;
// Create Time:  07/28/2011
// Operator:     liuzw
// Description:  银行卡号Luhm校验

// Luhm校验规则：16位银行卡号（19位通用）:

// 1.将未带校验位的 15（或18）位卡号从右依次编号 1 到 15（18），位于奇数位号上的数字乘以 2。
// 2.将奇位乘积的个十位全部相加，再加上所有偶数位上的数字。
// 3.将加法和加上校验位能被 10 整除。
function luhmCheck(cardNO: string): Boolean;
var
  szNum, crcNum: byte;
  I, k: Integer;
begin
  k := 0;
  for I := Length(cardNO) - 1 downto 1 do
  begin
    case k of
      0:
        begin
          szNum := (Ord(cardNO[I]) - Ord('0')) * 2;
          crcNum := crcNum + szNum mod 10 + szNum div 10;
        end;
      1:
        begin
          crcNum := crcNum + Ord(cardNO[I]) - Ord('0');
        end;
    end;
    k := 1 - k;
  end;
  Result := (crcNum + Ord(cardNO[Length(cardNO)]) - Ord('0')) mod 10 = 0;
  // 取出最后一位（与luhm进行比较）
end;
/// <summary>检查银行卡数据是否有效</summary>
function CheckBankCard(BankCard: string): string;
var
  I: Integer;
begin
  BankCard := Trim(BankCard);
  Result := '';
  if (BankCard = '') then
    Result := Result + '请填写银行卡号';
  if (Length(BankCard) < 16) or (Length(BankCard) > 19) then
    Result := Result + '银行卡号长度填写错误';
  for I := 1 to Length(BankCard) do
    if Pos(BankCard[I], '1234567890') < 1 then
      Result := Result + '银行卡号必须全为数字';
  if Pos(Copy(BankCard, 1, 2),
    '10,18,30,35,37,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,58,60,62,65,68,69,84,87,88,94,95,98,99')
    < 1 then
    Result := Result + '银行卡号开头2位不符合规范';
  if (not luhmCheck(BankCard)) then
    Result := Result + '银行卡号未通过系统检查';
end;

function CheckContainerNo(ContainerNo: string): string;
var
  S: string;
  i, idx, sum: Integer;
  function CharValue(C: Char): Byte;
  begin
    case C of
    'a', 'A': Result:= 10;
    'b', 'B': Result:= 12;
    'c', 'C': Result:= 13;
    'd', 'D': Result:= 14;
    'e', 'E': Result:= 15;
    'f', 'F': Result:= 16;
    'g', 'G': Result:= 17;
    'h', 'H': Result:= 18;
    'i', 'I': Result:= 19;
    'j', 'J': Result:= 20;
    'k', 'K': Result:= 21;
    'l', 'L': Result:= 23;
    'm', 'M': Result:= 24;
    'n', 'N': Result:= 25;
    'o', 'O': Result:= 26;
    'p', 'P': Result:= 27;
    'q', 'Q': Result:= 28;
    'r', 'R': Result:= 29;
    's', 'S': Result:= 30;
    't', 'T': Result:= 31;
    'u', 'U': Result:= 32;
    'v', 'V': Result:= 34;
    'w', 'W': Result:= 35;
    'x', 'X': Result:= 36;
    'y', 'Y': Result:= 37;
    'z', 'Z': Result:= 38;
    else raise Exception.Create('前4位箱主、经营人代码不正确');
    end;
  end;
  function NumValue(C: Char): Byte;
  begin
    case C of
    '0': Result:= 0;
    '1': Result:= 1;
    '2': Result:= 2;
    '3': Result:= 3;
    '4': Result:= 4;
    '5': Result:= 5;
    '6': Result:= 6;
    '7': Result:= 7;
    '8': Result:= 8;
    '9': Result:= 9;
    else raise Exception.Create('集装箱唯一标识不正确');
    end;
  end;
begin
  Result := '';
  if Length(ContainerNo) <> 11 then begin
    Result:= '请重新输入11位的集装箱编码！';
    Exit;
  end else try
    sum:= 0; Idx:= 1;
    for I := 1 to 4 do begin
      inc(sum, Idx * CharValue(ContainerNo[I]));
      Idx:= Idx * 2;
    end;
    for I := 5 to 10 do begin
      inc(sum, Idx * NumValue(ContainerNo[I]));
      Idx:= Idx * 2;
    end;
  except
    on E: Exception do begin
      Result:= E.Message;
      Exit;
    end;
  end;
  sum:= sum mod 11 - NumValue(ContainerNo[11]);
  if (sum <> 0) and (sum <> 10) then
    Result:= '集装箱号验证失败！';
end;

function CheckMobile(Mobile: string): string;
var
  Int: Int64;
begin
  Result := '';
  if Length(Mobile) <> 11 then begin
    Result:= '请重新输入11位手机号码！';
    Exit;
  end else if Pos(Mobile[2], '34578') <= 0 then begin
    Result:= '手机号码不正确！';
    Exit;
  end else if not tryStrToInt64(Mobile, Int) then begin
    Result:= '手机号码不正确！';
    Exit;
  end
end;

function CheckTrainNo(TrainNo: string): string;
var
  Int: Integer;
begin
  Result := '';
  if Length(TrainNo) <> 7 then begin
    Result:= '请重新输入7位车牌号码！';
    Exit;
  end else if Pos(TrainNo[1], '鲁京津沪浙苏冀豫辽吉黑渝蒙桂宁藏新港澳赣皖闵粤贵云鄂湘川琼晋陕甘青台军空海北沈兰济南广成武使') <= 0 then begin
    Result:= '车牌号码首位不正确！';
    Exit;
  end;
end;

{ TVonVersion }

function TVonVersion.Check(V: TVonVersion): Integer;
begin
  if Int = V.Int then Result:= 0
  else if Int > V.Int then Result:= 1 else Result:= -1;
end;

function TVonVersion.GetHex: string;
begin
  Result:= IntToHex(arr[3]) + IntToHex(arr[2]) +
    IntToHex(arr[1]) + IntToHex(arr[0]);
end;

function TVonVersion.GetText: string;
begin
  Result:= IntToStr(arr[3]) + '.' + IntToStr(arr[2]) + '.' + IntToStr(arr[1]) + '.' + IntToStr(arr[0]);
end;

procedure TVonVersion.SetHex(const Value: string);
var
  S: string;
begin
  S:= Copy('0000000000000000', 1, 16 - Length(Value)) + Value;
  arr[0]:= HexToInt(Copy(S, 13, 4));
  arr[1]:= HexToInt(Copy(S, 9, 4));
  arr[2]:= HexToInt(Copy(S, 5, 4));
  arr[3]:= HexToInt(Copy(S, 1, 4));
end;

procedure TVonVersion.SetText(const Value: string);
var
  Idx: Cardinal;
  P: PChar;
  szS: string;
begin
  P := PChar(Value);
  szS := '';
  Idx := 3;
  repeat
    case P[0] of
      '.':
        begin
          if szS = '*' then
            arr[Idx] := 65535
          else
            arr[Idx] := StrToInt(szS);
          szS := '';
          Dec(Idx);
        end;
    else
      szS := szS + P[0];
    end;
    Inc(P);
  until P[0] = #0;
  if szS = '*' then
    arr[Idx] := 65535
  else
    arr[Idx] := StrToInt(szS);
end;

initialization

FMCI_Handel := 0;
_ProcessorsCount := -1;
_BufferSize := $2000;
_PerfData := AllocMem(_BufferSize);
VI.dwOSVersionInfoSize := SizeOf(VI);
if not GetVersionEx(VI) then
  raise Exception.Create('Can''t get the Windows version');
_IsWinNT := VI.dwPlatformId = VER_PLATFORM_WIN32_NT;
FInfoList := TStringList.Create;    // 信息记录列表
FAppConfigList := TVonArraySetting.Create; // 应用系统配置文件内容列表
system_temp_string_List := TStringList.Create;
system_runtime_settings := TStringList.Create;
system_runtime_value := TStringList.Create;

finalization

ReleaseCPUData;
FreeMem(_PerfData);
FInfoList.Free;
FAppConfigList.Free; // 应用系统配置文件内容列表
system_temp_string_List.Free;
system_runtime_settings.Free;
system_runtime_value.Free;

end.


